请老师优化一下代码

wcj6376tcp

ykcbf1100 发表于 2024-3-9 20:53
没有附件，要改成通用，不太现实。首先：标题行有变化，其次，数据列有变化，第三，数据复制到目标表的位置 ...

Sub 合并目录下所有工作簿()
  Dim MyPath, MyName, AWbName, titleRow
  Dim Wb As Workbook, WbN As String
  Dim G As Long
  Dim Num As Long
  Dim T
  T = Timer
  Application.ScreenUpdating = False
  titleRow = InputBox("请输入标题行数", "默认行数", "3") '默认标题行数
    If titleRow = "" Then
    Exit Sub
    End If
  wjj = InputBox("请输入文件夹名称", "默认文件夹", "拆分文件") '需汇总的文件夹
  If wjj = "" Then Exit Sub
  MyPath = ThisWorkbook.Path & "\" & wjj
  If Len(Dir(MyPath, vbDirectory)) = 0 Then MkDir MyPath ' MkDir创建目录或文件夹
  MyName = Dir(MyPath & "\" & "*.xls*")
  AWbName = ActiveWorkbook.Name
  Sheets("汇总表").UsedRange.Offset(titleRow, 0).Clear '清除汇总表原数据保留标题
  Num = 0
  Do While MyName <> ""
  If MyName <> AWbName Then
    Set Wb = Workbooks.Open(MyPath & "\" & MyName)
    Num = Num + 1
    With Workbooks(1).ActiveSheet
      'For G = 1 To Sheets.Count
      MaxRow = .UsedRange.Rows.Count
      ActiveSheet.Range("A" & titleRow + 1 & ":E" & MaxRow).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
      'Next
      WbN = WbN & Chr(13) & Wb.Name
      Wb.Close False
    End With
  End If
  MyName = Dir
  Loop
  MaxRow2 = Sheets("汇总表").Range("A" & titleRow).End(xlDown).Row '行数
  Sheets("汇总表").Activate
  Cells(MaxRow2 + 1, 1).Value = "合计"
  Cells(MaxRow2 + 1, 2).Value = Application.WorksheetFunction.Sum(Range(Cells(titleRow + 1, 2), Cells(MaxRow2 + 1, 2)))
  Range("B1").Select
  Application.ScreenUpdating = True
  MsgBox "用时" & Format((Timer - T), "0.0000") & "秒，共合并了" & Num & "个工作薄如下：" & Chr(13) & WbN, vbInformation, "提示"
' 添加边框()
MaxCol = ActiveSheet.Range("A1").CurrentRegion.Columns.Count '获取列数
Range(Cells(titleRow, 1), Cells(MaxRow2 + 1, MaxCol)).Select
  With Selection.Borders
  .LineStyle = xlContinuous
  .ColorIndex = xlAutomatic
  .TintAndShade = 0
  .Weight = xlThin
  End With
End Sub
参考大师们的代码，基本实现了变量，但这句的E：麻烦修改一下 ActiveSheet.Range("A" & titleRow + 1 & ":E" & MaxRow).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

wcj6376tcp

已上传附件，请老师修改一下这句中的E：为变量  ActiveSheet.Range("A" & titleRow + 1 & ":E" & MaxRow).Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

wcj6376tcp

ykcbf1100 发表于 2024-3-9 20:53
没有附件，要改成通用，不太现实。首先：标题行有变化，其次，数据列有变化，第三，数据复制到目标表的位置 ...

请老师把:E这处修改为变量，感觉就应该适应行列变化通用了，谢谢

excel玉米

wcj6376tcp 发表于 2024-3-9 17:45
麻烦老师发一下代码呢？

Sub 合并目录下所有工作簿()
    Dim MyPath, MyName, Arr
    Dim Wb As Workbook, WbN As Workbook
    Dim G As Long, MaxRow%, MaxCol%
    Dim Num As Long, WbList As String  
   
    Application.ScreenUpdating = False
    G = InputBox("请输入表头行数")  '自定义表头行数
    Set WbN = ThisWorkbook
    WbN.Sheets("汇总表").UsedRange.Offset(G, 0).Clear   '清除汇总表原有数据，保留前三行表头
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = ThisWorkbook.Path               '默认路径为现有路径
      .Title = "选择文件夹"
      If .Show = False Then
         MsgBox "您选择""取消"",即将退出程序!"
         Exit Sub
      End If
      MyPath = .SelectedItems(1)
      MyName = Dir(MyPath & "\" & "*.xls*")
      Do While MyName <> ""
        If Split(MyName, ".xls")(0) <> WbN.Name Then  '如果和汇总表工作薄在同一文件夹，则排除汇总表
           Num = Num + 1
           WbList = WbList & Chr(13) & Split(MyName, ".xls")(0)
           Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            With Wb.Sheets(1)     '第一个工作表
               MaxRow = .UsedRange.Rows.Count
               MaxCol = .UsedRange.Columns.Count
               Arr = .Range(.Cells(G + 1, 1), .Cells(MaxRow, MaxCol)).Value '将第四行及以下的数据读入数组（去掉表头）
               Wb.Close False
            End With
        End If
        With WbN.Sheets("汇总表")
            MaxRow = .UsedRange.Rows.Count
            .Cells(MaxRow, 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr '将数组读入汇总表中
        End With
        MyName = Dir
      Loop

      With WbN.Sheets("汇总表")
            MaxRow = .UsedRange.Rows.Count
            MaxCol = .UsedRange.Columns.Count
            .Cells(MaxRow + 1, 1) = "合计"
            .Cells(MaxRow + 1, 2) = "=sum(R[-" & MaxRow - 3 & "]C:R[-1]C)"
            With .Range(.Cells(G, 1), .Cells(MaxRow, MaxCol)).Borders ' 添加边框
              .LineStyle = xlContinuous
              .ColorIndex = xlAutomatic
              .TintAndShade = 0
              .Weight = xlThin
            End With
            .Activate
      End With
    End With
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄如下：" & Chr(13) & WbList, vbInformation, "提示"
End Sub

wcj6376tcp

excel玉米 发表于 2024-3-9 13:33
适用于自定义表头行数数量统一的情形。

老师按照你的运行好像只能汇总到最后一个，而且汇总表里会越来越长呢?

半百

wcj6376tcp 发表于 2024-3-10 09:18
请老师把:E这处修改为变量，感觉就应该适应行列变化通用了，谢谢

大约这样吧

excel玉米

wcj6376tcp 发表于 2024-3-10 10:04
老师按照你的运行好像只能汇总到最后一个，而且汇总表里会越来越长呢?

没有附件，我只是在你的代码基础上做修改，并没有经过测试。根据你的附图我无法知道原因。
你可以将你的部分数据脱敏后上传，以供测试

wcj6376tcp

excel玉米 发表于 2024-3-10 11:17
没有附件，我只是在你的代码基础上做修改，并没有经过测试。根据你的附图我无法知道原因。
你可以将你的 ...

附件已上传，汇总2就是搬的你的代码

ykcbf1100

没有源数据不好测试，附件供参考，代码在下一楼。

ykcbf1100

代码如下：

1. Sub 合并目录下所有工作簿()
   
2.     Dim MyPath, MyName, AWbName, titleRow
   
3.     Dim wb As Workbook, WbN As String
   
4.     Dim G As Long
   
5.     Dim Num As Long
   
6.     Dim T
   
7.     T = Timer
   
8.     Application.ScreenUpdating = False
   
9.     titleRow = InputBox("请输入标题行数", "默认行数", "3") '默认标题行数
   
10.     If titleRow = "" Then Exit Sub
    
11.     wjj = InputBox("请输入文件夹名称", "默认文件夹", "拆分文件") '需汇总的文件夹
    
12.     If wjj = "" Then Exit Sub
    
13.     Set ws = ThisWorkbook
    
14.     Set sh = ws.Sheets("汇总表")
    
15.     MyPath = ThisWorkbook.Path & "" & wjj
    
16.     If Len(Dir(MyPath, vbDirectory)) = 0 Then MkDir MyPath ' MkDir创建目录或文件夹
    
17.     MyName = Dir(MyPath & "" & "*.xls*")
    
18.     Sheets("汇总表").UsedRange.Offset(titleRow, 0).Clear '清除汇总表原数据保留标题
    
19.     Num = 0
    
20.     Do While MyName <> ""
    
21.         If MyName <> ws.Name Then
    
22.             Set wb = Workbooks.Open(MyPath & "" & MyName)
    
23.             Num = Num + 1
    
24.             With wb.Sheets(1)
    
25.                 MaxRow = .UsedRange.Rows.Count
    
26.                 MaxCol = .UsedRange.Columns.Count
    
27.                 r = Cells(Rows.Count, 1).End(3).Row
    
28.                 .Range("A" & titleRow + 1 & ":E" & MaxRow).Copy sh.Cells(r + 1, 1)
    
29.                 WbN = WbN & Chr(13) & wb.Name
    
30.                 wb.Close False
    
31.             End With
    
32.         End If
    
33.         MyName = Dir
    
34.     Loop
    
35.     With sh
    
36.         MaxRow2 = .Cells(Rows.Count, 1).End(3).Row '行数
    
37.         .Cells(MaxRow2 + 1, 1).Value = "合计"
    
38.         .Cells(MaxRow2 + 1, 2).Value = Application.WorksheetFunction.Sum(.Range(.Cells(titleRow + 1, 2), .Cells(MaxRow2 + 1, 2)))
    
39.         .Range("B1").Select
    
40.         Application.ScreenUpdating = True
    
41.         MsgBox "用时" & Format((Timer - T), "0.0000") & "秒，共合并了" & Num & "个工作薄如下：" & Chr(13) & WbN, vbInformation, "提示"
    
42.         ' 添加边框()
    
43.         MaxCol = .UsedRange.Columns.Count  '获取列数
    
44.         Range(.Cells(titleRow, 1), .Cells(MaxRow2 + 1, MaxCol)).Select
    
45.         With Selection.Borders
    
46.             .LineStyle = xlContinuous
    
47.             .ColorIndex = xlAutomatic
    
48.             .TintAndShade = 0
    
49.             .Weight = xlThin
    
50.         End With
    
51.     End With
    
52. End Sub

复制代码