请路过大侠指点这种加上文件名的汇总用vba怎么做

xiaofan1999

这种加上文件名的汇总用vba怎么做，请路过大侠指点一下！！！

于箱长

只汇总数学语文英语？找找liulang0808版主的贴子，他有一个贴子专门是做各种汇总的

fzxba

1. Sub test1()
   
2.   Dim Conn As Object, Dict As Object, Cel As Range
   
3.   Dim strConn As String, p As String, f As String, s As String
   
4.   ActiveSheet.UsedRange.ClearContents
   
5.   Application.ScreenUpdating = False
   
6.   Range("A1").Resize(, 4) = Split("簿名,语文,数学,英语", ",")
   
7.   s = "Excel 12.0;HDR=yes;Database="
   
8.   If Application.Version < 12 Then
   
9.     s = Replace(s, "12.0", "8.0")
   
10.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
11.   Else
    
12.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
13.   End If
    
14.   Set Conn = CreateObject("ADODB.Connection")
    
15.   Conn.Open strConn & ThisWorkbook.FullName
    
16.   Set Cel = Range("A2")
    
17.   Set Dict = CreateObject("Scripting.Dictionary")
    
18.   p = ThisWorkbook.Path & "\"
    
19.   f = Dir(p & "*.xls*")
    
20.   While Len(f)
    
21.     If p & f <> ThisWorkbook.FullName Then
    
22.       Dict.Add "SELECT '" & Split(f, ".xls")(0) & "' AS 簿名,语文,数学,英语 FROM [" & s & p & f & "].[$A2:I]", vbNullString
    
23.       If Dict.Count = 49 Then
    
24.         Cel.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
25.         Set Cel = Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
26.         Dict.RemoveAll
    
27.       End If
    
28.     End If
    
29.     f = Dir
    
30.   Wend
    
31.   If Dict.Count Then Cel.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
32.   Conn.Close
    
33.   Set Conn = Nothing
    
34.   Set Cel = Nothing
    
35.   Set Dict = Nothing
    
36.   Application.ScreenUpdating = True
    
37.   Beep
    
38. End Sub

复制代码

gwjkkkkk

Sub TEST()
    Dim strFileName$, strPath$, wkb As Workbook, R&
    Dim iRow, arr, brr, i&, j&, iPosCol&, FName$
    Application.ScreenUpdating = False
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls*")
    ReDim brr(1 To 100000, 1 To 100)
    While strFileName <> ""
        If strFileName <> ThisWorkbook.Name Then
           Set wkb = GetObject(strPath & strFileName)
           With wkb.Sheets(1)
              arr = .[A2].CurrentRegion
              If UBound(arr, 2) + 1 > iPosCol Then iPosCol = UBound(arr, 2) + 1
              FName = Left(wkb.Name, InStrRev(wkb.Name, ".") - 1)
              R = R + 1: brr(R, 1) = FName
              For i = 1 To UBound(arr)
                    R = R + 1: brr(R, 1) = FName
                    For j = 1 To UBound(arr, 2)
                       brr(R, j + 1) = arr(i, j)
                    Next j
              Next i
           End With
           wkb.Close False
        End If
        strFileName = Dir
    Wend
    [A1].CurrentRegion.Cells.Clear
    [A1].Resize(R, iPosCol) = brr
    With [A1].CurrentRegion
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。请解压后使用。。。

xiaofan1999

gwjkkkkk 发表于 2022-11-21 20:02
请参考附件。。。请解压后使用。。。

谢谢大侠指点！！！

捞屎人

VBA拆分&amp;合并工作表20221114-5.7z (29.58 KB, 下载次数: 3)

2022-11-21 20:50 上传

点击文件名下载附件

以前写的作业 大概可以满足你的需求