合并簿

ddz79101

老师！我想合并工作簿到1表，有代码shiruiqiang老师的.但因我想对合并的工作簿想在旁注明，请老师帮忙看看如何再左修改，谢谢

chxw68

修改好了。

Qs18

1. Sub 合并()
   
2.     Dim Items As FileDialogSelectedItems, strPath$
   
3.     Dim sh As Worksheet
   
4.     Set sh = ThisWorkbook.Sheets(1)
   
5.     Set fso = CreateObject("scripting.filesystemobject")
   
6.     strPath = ThisWorkbook.Path & ""
   
7.     With Application.FileDialog(1)
   
8.          With .Filters
   
9.               .Clear
   
10.               .Add "Excel Files", "*.xls*"
    
11.          End With
    
12.         .AllowMultiSelect = True
    
13.         .InitialFileName = strPath
    
14.         If .Show Then Set Items = .SelectedItems Else Exit Sub
    
15.     End With
    
16.     Application.ScreenUpdating = False
    
17.     sh.UsedRange.Clear
    
18.     For Each vItem In Items
    
19.     t = VBA.InStrRev(vItem, "")
    
20.     t2 = VBA.InStrRev(vItem, ".")
    
21.     tt = Mid(vItem, t + 1, t2 - t - 1)
    
22.         With GetObject(vItem)
    
23.              If sh.[A1] = "" Then
    
24.                 .Sheets(1).[a1:e100].Copy sh.[A1]
    
25.                 c = sh.Cells(1, 100).End(xlToLeft).Column + 1
    
26.                 sh.Cells(1, c) = tt
    
27.              Else
    
28.                 icol = sh.Range("aa2").End(xlToLeft).Column + 2
    
29.                 .Sheets(1).[a1:e100].Copy sh.Cells(1, icol)
    
30.                 c2 = sh.Cells(1, 100).End(xlToLeft).Column + 1
    
31.                 sh.Cells(1, c2) = tt
    
32.              End If
    
33.             .Close False
    
34.        End With
    
35.     Next
    
36. 
    
37.     Set Items = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     Beep
    
40. End Sub
    
41. 
    
42. 
    
43. 
    
44. 
    

复制代码

Qs18

改好了...............

Qs18

改好了.........

ddz79101

chxw68 发表于 2024-9-4 21:20
修改好了。

谢谢老师！运行后发现簿名覆盖了数据列。可以再修改吗

ddz79101

Qs18 发表于 2024-9-4 21:43
改好了.........

谢谢老师！运行完美！

quqiyuan

参与一下，简单修改了下。。。

quqiyuan

代码如下。。。
Sub 合并()
    Dim Items As FileDialogSelectedItems, strPath$
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets(1)
    Set fso = CreateObject("scripting.filesystemobject")
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(1)
         With .Filters
              .Clear
              .Add "Excel Files", "*.xls*"
         End With
        .AllowMultiSelect = True
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
  
    Application.ScreenUpdating = False
    sh.UsedRange.Clear
    For Each vitem In Items
        With GetObject(vitem)
             If sh.[A1] = "" Then
                .Sheets(1).[a1:e100].Copy sh.[A1]
             Else
                icol = sh.Range("aa2").End(xlToLeft).Column + 1
                .Sheets(1).[a1:e100].Copy sh.Cells(1, icol)
             End If
                icol = sh.Range("aa2").End(xlToLeft).Column
                irow = sh.Cells(Rows.Count, icol).End(3).Row
                sh.Cells(1, icol + 1).Resize(irow) = fso.getbasename(vitem)
            .Close False
       End With
    Next
    sh.Columns("a:iv").AutoFit
    Set Items = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

sero61

才疏学浅 琢磨了半天已经有大神给出结果了 ，巨人的肩膀上了不好站啊 ，献丑了
Sub 合并()
    Dim Items As FileDialogSelectedItems, strPath$
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets(1)
    Set fso = CreateObject("scripting.filesystemobject")
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(1)
         With .Filters
              .Clear
              .Add "Excel Files", "*.xls*"
         End With
        .AllowMultiSelect = True
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
  
    Application.ScreenUpdating = False
    sh.UsedRange.Clear
    For Each vitem In Items
        With GetObject(vitem)
             If sh.[a1] = "" Then
                .Sheets(1).[a1:e100].Copy sh.[a1]
               sh.[a1].End(2).Offset(0, 1) = fso.getbasename(vitem)
             Else
                icol = sh.Range("aa2").End(xlToLeft).Column + 2
                .Sheets(1).[a1:e100].Copy sh.Cells(1, icol)
               sh.Range("a1").End(2).Offset(0, 1) = fso.getbasename(vitem)
             End If
            .Close False
       End With
    Next

    Set Items = Nothing
    Application.ScreenUpdating = True
    Beep