跨文件数据汇总到总表

LIUZHU

sulli112 发表于 2024-5-13 15:10
不好意思想请教一下，您这段代码市合并文件夹下工作簿数据吗？为啥我测试了一下，好像只合并第一份文件夹 ...

每个文件夹下面的工作簿数量是多于1个吗？如果是，那么代码要修改，因为我看到目前给出的样例，好像是每个文件夹下面就一个文件，所以代码设计成只读取一个文件。

sulli112

LIUZHU 发表于 2024-5-13 15:25
每个文件夹下面的工作簿数量是多于1个吗？如果是，那么代码要修改，因为我看到目前给出的样例，好像是每 ...

我测试了一下，1.每个工作簿只有一个表格，合并总表数据也是不完整，你看楼主的附件，数据上百条，但是我运行你的代码只有30条数据带过去2.如果多工作簿情况需要怎么修改呢

sulli112

ykcbf1100 发表于 2024-5-13 11:03
参与一下。。。

您好，如果修改为A列数据也取的情况下，是不是只要修改红色列代码即可
Sub ykcbf()   '//2024.5.13
    Application.ScreenUpdating = False
    Dim fns As New Collection
    p = ThisWorkbook.Path & "\"
    Set sh = ThisWorkbook.Sheets("Sheet4")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ff = fso.GetFolder(p)
    getFiles ff, fns, fso
    ReDim brr(1 To 10000, 1 To 300)
    For Each f In fns
        Set wb = Workbooks.Open(f, 0)
        With wb.Sheets(1)
            r = .Cells(Rows.Count, 1).End(3).Row
            c = .UsedRange.Columns.Count
            arr = .[a1].Resize(r, c)
        End With
        wb.Close False
        For i = 2 To UBound(arr)
            m = m + 1
            For j = 1 To UBound(arr, 2)
                brr(m, j) = arr(i, j)
            Next
        Next
    Next
    With sh
        .Rows(4 & ":" & 1000) = ""
        .[a4].Resize(m, c - 1) = brr
        .[a4].Resize(m, c - 1).Borders.LineStyle = 1
    End With
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub

Function getFiles(ff, fns, fso)
    For Each f In ff.Files
        If InStr(f, "~$") = 0 Then
            If InStr(f, ThisWorkbook.Name) = 0 Then
                fns.Add f.Path
            End If
        End If
    Next
    For Each fd In ff.SubFolders
        getFiles fd, fns, fso
    Next
End Function

ykcbf1100

sulli112 发表于 2024-5-13 15:50
您好，如果修改为A列数据也取的情况下，是不是只要修改红色列代码即可
Sub ykcbf()   '//2024.5.13
    ...

写入也有关系。

sulli112

ykcbf1100 发表于 2024-5-13 17:12
写入也有关系。

还要修改哪里吗？

ykcbf1100

sulli112 发表于 2024-5-13 18:33
还要修改哪里吗？

c-1改为C。。。

sulli112

ykcbf1100 发表于 2024-5-13 18:43
c-1改为C。。。

好的，非常感谢

baofa2

1. Sub test1() '练习，灌水增产……
   
2.   
   
3.   Dim i As Long, p As Long, iCount As Long
   
4.   Dim Conn As Object, dict As Object ', Fso As Object
   
5.   Dim strConn As String, strSQL As String, s As String
   
6.   Dim path_ As String, files_(1 To 2345) As String
   
7.   
   
8.   path_ = ThisWorkbook.Path & "\"
   
9. '  If Not GetFileName(Files_, Path_, ".xlsx") Then MsgBox "!": Exit Sub
   
10.   GetFiles path_, CreateObject("Scripting.FileSystemObject"), files_(), iCount, "~$", ".xls"
    
11.   If iCount = 0 Then MsgBox "!": Exit Sub
    
12.   
    
13.   p = 4
    
14.   Rows(p & ":" & Rows.Count).ClearContents
    
15.   
    
16.   Application.ScreenUpdating = False
    
17.   
    
18.   Set Conn = CreateObject("ADODB.Connection")
    
19.   Set dict = CreateObject("Scripting.Dictionary")
    
20.   
    
21.   s = "Excel 12.0;HDR=YES;IMEX=1;Database="
    
22.   If Application.Version < 12 Then
    
23.     s = Replace(s, "12.0", "8.0")
    
24.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
25.   Else
    
26.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
27.   End If
    
28.   
    
29.   strSQL = "SELECT * FROM [" & s & "[.File]].[$B1:BP] WHERE `Lot Number_批号` IS NOT NULL"
    
30.   For i = 1 To iCount
    
31.     If files_(i) <> ThisWorkbook.FullName Then
    
32.       If Conn.State <> 1 Then Conn.Open strConn & files_(i)
    
33.       dict.Add Replace(strSQL, "[.File]", files_(i)), ""
    
34.       If dict.Count = 49 Then
    
35.         Range("A" & p).CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
36.         p = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
    
37.         dict.RemoveAll
    
38.       End If
    
39.     End If
    
40.   Next
    
41.   If dict.Count Then Range("A" & p).CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
42.   
    
43.   With ActiveSheet.UsedRange
    
44.     .Borders.LineStyle = xlContinuous
    
45.     .HorizontalAlignment = xlCenter
    
46.   End With
    
47.   
    
48.   Conn.Close
    
49.   Set Conn = Nothing
    
50.   Set dict = Nothing
    
51.   Application.ScreenUpdating = True
    
52.   Beep
    
53. End Sub
    
54. 
    
55. Function GetFiles(path_ As String, Fso As Object, files_() As String, iCount As Long, strExclude As String, Optional strFilter As String = ".xls")
    
56.   Dim folder_ As Object, file_ As Object
    
57.   For Each folder_ In Fso.GetFolder(path_).SubFolders
    
58.     For Each file_ In folder_.Files
    
59.       If InStr(LCase(file_.Name), strFilter) Then
    
60.         If Not file_.Name Like strExclude & "*" Then
    
61.           iCount = iCount + 1
    
62.           files_(iCount) = file_.Path
    
63.         End If
    
64.       End If
    
65.     Next
    
66.   Next
    
67. End Function

复制代码

jjmysjg

LIUZHU 发表于 2024-5-12 11:34
JS代码，请参考

那的JS代码怎么能在EXCEL上使用

LIUZHU

jjmysjg 发表于 2024-5-14 08:49
那的JS代码怎么能在EXCEL上使用

抱歉，JSA代码不能在Excel用，只能在WPS2019版上用。
要在Excel上使用，必须转换成VBA代码