|
|
本帖最后由 1016373263 于 2020-10-11 08:34 编辑
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim d As Object, sht As Worksheet, arr, file As String, n%, k%
Set d = CreateObject("scripting.dictionary")
Set sht = Worksheets("查询表")
file = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While file <> ""
If file <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & file
n = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
arr = ActiveWorkbook.Worksheets(1).Range("b2:d" & n)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 1))(arr(i, 2)) = arr(i, 3)
Next i
ActiveWorkbook.Close False
End If
file = Dir
Loop
v = 2
k = d.Count - 1
For j = 0 To k
If d(sht.Cells(v, 2).Value).Count = 1 Then
sht.Cells(v, 6) = d(sht.Cells(v, 2).Value).keys
sht.Cells(v, 7) = d(sht.Cells(v, 2).Value).items
v = v + 1
Else
sht.Rows(v + 1).EntireRow.Resize(d(sht.Cells(v, 2).Value).Count - 1).Insert
sht.Cells(v, 6).Resize(d(sht.Cells(v, 2).Value).Count, 1) = Application.Transpose(d(sht.Cells(v, 2).Value).keys)
sht.Cells(v, 7).Resize(d(sht.Cells(v, 2).Value).Count, 1) = Application.Transpose(d(sht.Cells(v, 2).Value).items)
For Z = 2 To 5
sht.Cells(v, Z).Resize(d(sht.Cells(v, 2).Value).Count, 1).MergeCells = True
Next Z
v = v + d(sht.Cells(j + 2, 2).Value).Count
End If
Next
Application.ScreenUpdating = True
End Sub |
|
楼主: lele400024
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2020-9-30 12:06
