excel批量修改多个工作簿的标题，及工作簿中多张工作表中的同一内容

520_123456

求大神帮忙！l批量修改多个工作簿的标题，及工作簿中多张工作表中的同一内容



我这里有1000人，每个人对应一张单独的工作簿，现在的问题有两个：

   一,把工作簿的名称中的班级更改为：现在的班级（之前的班级是：分班前；现在的是：分班后）
      ( 说明：工作簿的名称=班级+姓名_学籍号   例：1班（张三L1234567890123） )

   二,把工作簿中的所有工作表中的班级信息更改为：现在的班级

另外，有一张学生信息表作为班级参考。唯一关键字是：学籍号。（可以根据学籍号查找到对应的班级信息）

520_123456

第一步，根据工作簿的名称中的学籍号 先到 学生信息表中查找到对应的人的班级
第二步，修改工作簿名称中的班级
第三步，打开工作簿，修改工作簿中每张表的班级信息
第四步，保存，关闭。

看起来简单，量大了，做完好难！  
  

520_123456

学生信息表

需要修改的工作簿

327718098

520_123456 发表于 2017-5-11 20:22

不知道你的电脑能不能同时打开1000多个工作簿，呵呵

人可凡

思路：
1、原来的文件名有没有目录？ 如果没有可以用笨办法，把所有的工作簿集中在D:\old文件夹中，然后用DOS命令，运行CMD,然后用 DIR d:\old\*.* >d:\wjml.txt     接着，打开D:\WJML.TXT，把内容复制到EXCEL中，利用分列得到所有文件名
2、得到目录后，利用VLOOKUP 根据学籍号 匹配相应的位置，
3、利用宏，执行批处理方法，把文件名复制或者改名。
4、得到对应的文件名后，（如果工作表内容是一样的，宏就好写了）只是一个打开和写入的操作。

327718098

你把原文件复制一份测试一下，检查看有没有问题，你这个要考虑的太多了，我怕没考虑到
Sub text()
Dim rng As Range, wr As Worksheet, lj1 As String, lj2 As String, wb As String
lj1 = ThisWorkbook.Path & "\"
lj2 = Dir(lj1 & "*.xl*")
Do While lj2 <> ""
If lj2 <> ThisWorkbook.Name Then
Workbooks.Open (lj1 & lj2)
Set rng = Workbooks("学生信息表（含学籍号、班级）.xlsx").Sheets("sheet1").Range("a:a").Find(ActiveWorkbook.Sheets("学生登记表").Range("f5"))
For Each wr In ActiveWorkbook.Sheets
If wr.Name = "学生登记表" Then
wr.Cells(2, 1) = "××市教育局   ××区教育局   ××省××中学   2014级  高中2014级" & rng.Offset(0, 2) & "班"
ElseIf wr.Name = "综合素质-终结性评价" Then
wr.Cells(2, 1) = "××省××中学  2014级  高中2014级" & rng.Offset(0, 2) & "班"
ElseIf wr.Name = "体检表" Then
wr.Cells(2, 1) = "××省××中学   2014级  高中2014级" & rng.Offset(0, 2) & "班"
Else
wb = Right(wr.Cells(3, 1).Value, 12)
wr.Cells(3, 1) = "××省××中学  高中2014级" & rng.Offset(0, 2) & "班 学生姓名：" & rng.Offset(0, 1) & "学籍号：" & rng & "考籍号：" & wb
End If
Next
ActiveWorkbook.SaveAs Filename:=lj1 & "综合素质评价报告单" & rng.Offset(0, 2) & "班(白学羲_G513021200005038624)"
ActiveWorkbook.Close saverange = True
End If
lj2 = Dir
Loop
End Sub

327718098

327718098 发表于 2017-5-12 15:47
你把原文件复制一份测试一下，检查看有没有问题，你这个要考虑的太多了，我怕没考虑到
Sub text()
Dim rn ...

似乎还要改一下，不然年级全是高三回去在改

327718098

520_123456 发表于 2017-5-11 19:51
第一步，根据工作簿的名称中的学籍号 先到 学生信息表中查找到对应的人的班级
第二步，修改工作簿名称中的 ...

在工作簿所在的路径新建一个文件夹修改用来保存修改好的数据，应为工作簿正在运行，无法直接更改名称，只能另存，还是一样把源数据复制一份来测试，基本上没什么问题，ActiveWorkbook.SaveAs Filename:=lj1 & "\" & "新建文件夹" & "\" & "综合素质评价报告单" & rng.Offset(0, 2) & "班(" & rng.Offset(0, 1) & "_" & 这一句前面的部分就是指定保存路径

Sub text()
Application.ScreenUpdating = False
Dim rng As Range, wr As Worksheet, lj1 As String, lj2 As String, wb As String, wb1 As String
lj1 = ThisWorkbook.Path & "\"
lj2 = Dir(lj1 & "*.xl*")
Do While lj2 <> ""
If lj2 <> ThisWorkbook.Name Then
Workbooks.Open (lj1 & lj2)
wb1 = Mid(ActiveWorkbook.Worksheets("学生登记表").Range("a2"), 29, 15)
Set rng = Workbooks("学生信息表（含学籍号、班级）.xlsx").Sheets("sheet1").Range("a:a").Find(ActiveWorkbook.Sheets("学生登记表").Range("f5"))
For Each wr In ActiveWorkbook.Sheets
If wr.Name = "学生登记表" Then
wr.Cells(2, 1) = "××市教育局   ××区教育局   ××省××中学   " & wb1 & rng.Offset(0, 2) & "班"
ElseIf wr.Name = "综合素质-终结性评价" Then
wr.Cells(2, 1) = "××省××中学" & wn1 & rng.Offset(0, 2) & "班"
ElseIf wr.Name = "体检表" Then
wr.Cells(2, 1) = "××省××中学" & wb1 & rng.Offset(0, 2) & "班"
Else
wb = Right(wr.Cells(3, 1).Value, 12)
wr.Cells(3, 1) = "××省××中学" & wb1 & rng.Offset(0, 2) & "班 学生姓名：" & rng.Offset(0, 1) & "学籍号：" & rng & "考籍号：" & wb
End If
Next
ActiveWorkbook.SaveAs Filename:=lj1 & "\" & "新建文件夹" & "\" & "综合素质评价报告单" & rng.Offset(0, 2) & "班(" & rng.Offset(0, 1) & "_" & rng.Value & ".xls"
ActiveWorkbook.Close saverange = True
End If
lj2 = Dir
Loop
Application.ScreenUpdating = True
End Sub

人可凡

在D盘下建立OLD,把所有之前的文件全复制到那里
运行EXCEL中的"运行",生成新的XLSX文件放在d:\old\new中
最好用OFFICE2010以上版本，宏限制取消（不能用WPS)

如果要生成.XLS文件则宏的最后几行需要改成
file2 = "D:\old\new\综合素质评价报告单" & bj & "班(" & xm & "_" & xjh & ")" & ".xls"
    ActiveWorkbook.SaveAs Filename:=file1, _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False