用VBA把同一目录多个工作簿每个工作表SHEET0按考场插入两个空行，学校列填写相同校名

朝露孤烟 · 发表于 2024-5-14 16:00

向各位大佬求助。用VBA处理：同一目录有多个工作簿，每个工作簿有一个工作表SHEET0，每个工作表需要按考场插入两个空行，并且学校列空行处填写同列的校名。截图是需要的结果。谢谢！

3190496160 · 发表于 2024-5-14 20:22

Sub 插入行()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
   r = .Cells(Rows.Count, 1).End(xlUp).Row
   ar = .Range("a1:h" & r)
   d(r + 1) = r + 1
   For i = UBound(ar) To 2 Step -1
      If ar(i, 5) <> "" Then
         d(ar(i, 5)) = i
      End If
Next i
x = d.keys
For i = 0 To UBound(x) - 1
      kc = x(i)
      xh = d(x(i))
      .Rows(xh & ":" & xh + 1).Insert Shift:=xlDown
      .Cells(xh, 3) = .Cells(xh - 1, 3)
      .Cells(xh + 1, 3) = .Cells(xh - 1, 3)
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

魚。。 · 发表于 2024-5-14 20:26

魚.rar (1.93 MB, 下载次数: 1)

把附件和需要处理文件放同一个文件夹内，然后点哪吒！

longwin · 发表于 2024-5-14 20:30

请测试.....

3190496160 · 发表于 2024-5-14 20:33

Sub 插入行()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(lj & f, 0)
      With wb.Worksheets(1)
         r = .Cells(Rows.Count, 1).End(xlUp).Row
         ar = .Range("a1:h" & r)
         d(r + 1) = r + 1
         For i = UBound(ar) To 2 Step -1
            If ar(i, 5) <> "" Then
                  d(ar(i, 5)) = i
            End If
         Next i
         x = d.keys
         For i = 0 To UBound(x) - 1
            kc = x(i)
            xh = d(x(i))
            .Rows(xh & ":" & xh + 1).Insert Shift:=xlDown
            .Cells(xh, 3) = .Cells(xh - 1, 3)
            .Cells(xh + 1, 3) = .Cells(xh - 1, 3)
         Next i
      End With
      wb.Close True
End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-5-14 20:34

考场信息打印.rar (88.4 KB, 下载次数: 5)

朝露孤烟 · 发表于 2024-5-15 08:55

3190496160 发表于 2024-5-14 20:22
Sub 插入行()
Application.ScreenUpdating = False
Dim d As Object, dc As Object

谢谢！我先试试。

朝露孤烟 · 发表于 2024-5-15 08:55

longwin 发表于 2024-5-14 20:30
请测试.....

谢谢！我先试试。

朝露孤烟 · 发表于 2024-5-15 09:24

魚。。发表于 2024-5-14 20:26
把附件和需要处理文件放同一个文件夹内，然后点哪吒！

已测试，正常处理。谢谢！

3190496160 · 发表于 2024-5-15 10:06

5楼代码有误，以此为准

考场信息打印.rar (97.26 KB, 下载次数: 0)

		自动登录	找回密码
密码			免费注册

[求助] 用VBA把同一目录多个工作簿每个工作表SHEET0按考场插入两个空行，学校列填写相同校名

评分

评分

评分