选簿合并1表

ddz79101

老师！有文件夹（路径不定），我想对其中的任意工作簿合并到另1簿1表中，并横向放置。请老师帮忙指点。谢谢

ddz79101

有老师看看帮忙吗

ddz79101

ddz79101 发表于 2024-5-16 16:49
有老师看看帮忙吗

有帮忙看看的麻

shiruiqiang

================

baofa2

1. Option Explicit
   
2. 
   
3. Sub test0() '
   
4.   
   
5.   Dim Files_ As FileDialogSelectedItems
   
6.   
   
7.   With Application.FileDialog(msoFileDialogFilePicker)
   
8.     .InitialFileName = ThisWorkbook.Path
   
9.     With .Filters
   
10.       .Clear
    
11.       .Add "Excel Files", "*.xls*"
    
12.     End With
    
13.     .AllowMultiSelect = True
    
14.     If .Show Then Set Files_ = .SelectedItems Else Exit Sub
    
15.   End With
    
16.   
    
17.   Cells.ClearContents
    
18.   DoApp False
    
19.   
    
20.   Dim File_, j As Long, s As String
    
21.   Dim Conn As Object, strConn As String, strSQL As String
    
22.   Set Conn = CreateObject("ADODB.Connection")
    
23.   
    
24.   s = "Excel 12.0;HDR=NO;Database="
    
25.   If Application.Version < 12 Or InStr(Application.Path, "WPS") > 0 Then
    
26.     s = Replace(s, "12.0", "8.0")
    
27.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
    
28.   Else
    
29.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
    
30.   End If
    
31.   
    
32.   
    
33.   j = 1
    
34.   strSQL = "SELECT * FROM [" & s & "[.File_]].[$A:IV]"
    
35.   For Each File_ In Files_
    
36.     If ThisWorkbook.FullName <> File_ Then
    
37.       If Conn.State <> 1 Then Conn.Open strConn & File_
    
38.       Cells(1, j).CopyFromRecordset Conn.Execute(Replace(strSQL, "[.File_]", File_))
    
39.       j = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    
40.       j = j - (j > 1) * 2
    
41.     End If
    
42.   Next
    
43.   
    
44.   Set Files_ = Nothing
    
45.   If Conn.State = 1 Then Conn.Close
    
46.   Set Conn = Nothing
    
47.   
    
48.   DoApp
    
49.   Beep
    
50. End Sub
    
51. 
    
52. Function DoApp(Optional b As Boolean = True)
    
53.   With Application
    
54.     .ScreenUpdating = b
    
55.     .DisplayAlerts = b
    
56.     .Calculation = -b * 30 - 4135
    
57.   End With
    
58. End Function
    

复制代码

ykcbf1100

参与一下。工作簿多选时，请先按下ctrl键，再点选你需要合并的文件。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.16
   
2.     Dim arr, fns
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     sh.UsedRange.Clear
   
7.     With Application.FileDialog(msoFileDialogFilePicker)
   
8.         .Title = "请选择文件夹"
   
9.         .InitialFileName = ThisWorkbook.Path & ""
   
10.         .AllowMultiSelect = True
    
11.         .Filters.Clear
    
12.         .Filters.Add "Excel Files", "*.xls?"
    
13.         .Filters.Add "All Files", "*.*"
    
14.         If .Show Then Set fns = .SelectedItems Else Exit Sub
    
15.     End With
    
16.     For Each f In fns
    
17.         n = n + 1
    
18.         Set wb = Workbooks.Open(f, 0)
    
19.         With wb.Sheets("Sheet1")
    
20.             arr = .UsedRange
    
21.             wb.Close False
    
22.         End With
    
23.         If n = 1 Then
    
24.             sh.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
25.         Else
    
26.             col = sh.Cells(1, 255).End(1).Column
    
27.             sh.Cells(1, col + 2).Resize(UBound(arr), UBound(arr, 2)) = arr
    
28.         End If
    
29.     Next
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

ddz79101

shiruiqiang 发表于 2024-5-16 18:20
================

谢谢老师！运行成功！棒极了

ddz79101

baofa2 发表于 2024-5-16 18:49

谢谢老师！运行顺利

ddz79101

ykcbf1100 发表于 2024-5-16 19:41
参与一下。工作簿多选时，请先按下ctrl键，再点选你需要合并的文件。

谢谢老师！运行成功。棒极了