求VBA程序

923940

数据整合用，要在一个表格内提取另外10多个表格的数据。求帮助。

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
With Sheets("Sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r >= 4 Then .Range(.Cells(4, 1), .Cells(r, y)) = Empty
    ar = .Range(.Cells(1, 1), .Cells(1000, y))
    For j = 2 To UBound(ar, 2) Step 4
        If Trim(ar(1, j)) <> "" Then
            zf = Left(Trim(ar(1, j)), 5)
            d(zf) = j
        End If
    Next j
   f = Dir(lj & "*.xls*")
   k = 3
   Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(lj & f, 0)
            With wb.Worksheets(1)
                rs = .Cells(Rows.Count, 1).End(xlUp).Row
                br = .Range("a1:e" & rs)
            End With
            mc = Left(wb.Name, 5)
            wb.Close False
            lh = d(mc)
            If lh <> "" Then
                For i = 4 To UBound(br)
                    If Trim(br(i, 1)) <> "" Then
                        t = d(Trim(br(i, 1)))
                        If t = "" Then
                            k = k + 1
                            d(Trim(br(i, 1))) = k
                            t = k
                            ar(k, 1) = br(i, 1)
                        End If
                        For j = 2 To 5
                            ar(t, lh + j - 2) = br(i, j)
                        Next j
                    End If
                Next i
            End If
        End If
    f = Dir
    Loop
    .[a1].Resize(k, y) = ar
    .[a1].Resize(k, y).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

数据提取整合.rar (36.21 KB, 下载次数: 15)

2023-4-29 22:44 上传

点击文件名下载附件

zxsea_7426

附件就一个主文件。

mmwwdd

Sub test()
Set d = CreateObject("scripting.dictionary")
Set dw = CreateObject("scripting.dictionary")
Dim MyPath$, MyName$
Dim wb As Workbook
Dim ws As Worksheet
Rows(4 & ":" & Rows.Count).Clear
Set ws = ThisWorkbook.Sheets(1)
For j = 1 To Cells(1, Columns.Count).End(1).Column
  If Cells(1, j).MergeArea.Cells(1, 1).Address = Cells(1, j).Address Then
    d(Cells(1, j).Value) = j
  End If
Next
r = 3
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls*")
Do While MyName <> ""
   If MyName <> ThisWorkbook.Name Then
      Set wb = GetObject(MyPath & MyName)
          mm = Val(wb.Name)
          For Each aa In d.keys
             If InStr(aa, mm) <> 0 Then
                ls = d(aa)
                Exit For
             End If
          Next
            With wb.Sheets(1)
'            MsgBox .Range("A1").CurrentRegion.Rows.Count
            arr = .Range("A1").CurrentRegion.Offset(3, 0).Resize(.Range("A1").CurrentRegion.Rows.Count - 3, 5)
            For i = 1 To UBound(arr)
              ss = ls
              If Not dw.exists(arr(i, 1)) Then
                 r = r + 1
                 dw(arr(i, 1)) = r
                 
                 For k = 2 To UBound(arr, 2)
                     ws.Cells(r, ss) = arr(i, k)
                     ss = ss + 1
                     ws.Cells(r, 1) = arr(i, 1)
                    
                 Next
               Else
                 For k = 2 To UBound(arr, 2)
                   ws.Cells(dw(arr(i, 1)), ss) = arr(i, k)
                   ss = ss + 1
                 Next
               End If
           Next
          End With
        wb.Close
    End If

    MyName = Dir

Loop

End Sub

mmwwdd

mmwwdd

是这样的吧，按要求弄了

gwjkkkkk

参与一下。。。

923940

感谢各位大佬百忙之中帮忙！！！