求如何汇总数据

wzd028

运行VBA，要求按单元格各项名称导入“报价”表格内各工作表对应项的数据，“报价”各工作表表头会不一样。


      汇总.rar (181.12 KB, 下载次数: 17)

2024-1-31 15:50 上传

点击文件名下载附件

ykcbf1100

原附件取值有误，已更新代码。

ykcbf1100

原代码取值有误，现更新一下。

1. Sub ykcbf()   '//2024.2.1
   
2.     Dim arr, brr(1 To 10000, 1 To 6), d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("Sheet1")
   
8.     For j = 1 To 6
   
9.         s = sh.Cells(3, j)
   
10.         d(s) = j
    
11.     Next
    
12.     p = ws.Path
    
13.     f = p & "\报价.xlsx"
    
14.     Set wb = Workbooks.Open(f, 0)
    
15.     On Error Resume Next
    
16.     For Each sht In wb.Sheets
    
17.         With sht
    
18.             arr = .UsedRange
    
19.         End With
    
20.         For i = 3 To UBound(arr)
    
21.             If arr(i, 2) <> Empty Then
    
22.                 m = m + 1
    
23.                 For j = 2 To UBound(arr, 2)
    
24.                     s = arr(2, j)
    
25.                     If d.exists(s) Then
    
26.                         brr(m, d(s)) = arr(i, j)
    
27.                     End If
    
28.                 Next
    
29.             End If
    
30.         Next
    
31.     Next
    
32.     wb.Close False
    
33.     With sh
    
34.         .[a4:f100000].ClearContents
    
35.         With .[a4].Resize(m, 6)
    
36.             .Value = brr
    
37.             .Borders.LineStyle = 1
    
38.             .HorizontalAlignment = xlCenter
    
39.             .VerticalAlignment = xlCenter
    
40.         End With
    
41.     End With
    
42.     Set d = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    

复制代码

fzxba

汇总.zip (256.68 KB, 下载次数: 16)

2024-1-31 16:27 上传

点击文件名下载附件

蓝桥玄霜

汇总的例子：

wzd028

谢谢各位老师

feilanga

wzd028 发表于 2024-1-31 17:12
谢谢各位老师

各位老师帮你用了很多时间来写代码，尽可能献上鲜花以表感谢，当时没有过后补上。再就是感谢的话语直接回复给单个老师，那是诚意。而不是随意回复。这是做人做事的道理。

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, br, i&, j&, r&, dic As Object, t#
    Dim strFileName$, strPath$, wks As Worksheet, iPosCol&
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "报价.xlsx"
    If Dir(strFileName) = "" Then MsgBox "报价文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    With [A3].CurrentRegion
        .Offset(1).Clear
        ar = .Resize(10 ^ 3)
        r = 1
        For j = 1 To UBound(ar, 2)
            dic(ar(1, j)) = j
        Next j
    End With
    With GetObject(strFileName)
        For Each wks In .Worksheets
            br = wks.[A1].CurrentRegion.Value
            For i = 3 To UBound(br)
                r = r + 1
                For j = 1 To UBound(br, 2)
                    If dic.exists(br(2, j)) Then
                        iPosCol = dic(br(2, j))
                        ar(r, iPosCol) = br(i, j)
                    End If
                Next j
            Next i
        Next
    End With
   
    With [A3].Resize(r, UBound(ar, 2))
        .Value = ar
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Rows(1).Font.Bold = True
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

参与一下。。。

cjc209

ykcbf1100 发表于 2024-1-31 16:00
附件供参考。。。

你的品牌提取应该不对 你提取的是工作表名