[已解决]求用VBA把数据汇总到另一个表格

wzd28

有3个表格，要把数据汇总到“各公司报价汇总”表里面，具体见附件，谢谢。
    报价汇总.rar (244.8 KB, 下载次数: 58)

2022-7-3 16:56 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

我行我速2008

2022-7-8 16:14

试试吧！！！！！

跳转到最佳答案楼层

eennoo

1

我行我速2008

试试吧！！！

wzd28

我行我速2008 发表于 2022-7-6 14:05
试试吧！！！

你好，谢谢你的帮助，点击清除按钮后，再点击“报价汇总”按钮不能导入数据，不知道是不是版本问题，我用的是2016版。

我行我速2008

我电脑中没问题

我行我速2008

wzd28 发表于 2022-7-6 15:14
你好，谢谢你的帮助，点击清除按钮后，再点击“报价汇总”按钮不能导入数据，不知道是不是版本问题，我用 ...

我对你发的表格做了修改，所以要用我发的表格才行。

wzd28

我行我速2008 发表于 2022-7-6 16:36
我对你发的表格做了修改，所以要用我发的表格才行。

老师，可以导入数据了，我在“各公司报价汇总”表又增加了一列备注栏，点击“报价汇总”按钮导入数据出错，麻烦老师帮忙修改一下，谢谢。
   报价汇总20220708.rar (361.25 KB, 下载次数: 3)

2022-7-8 14:02 上传

点击文件名下载附件

我行我速2008

试试吧！！！！！

wzd28

我行我速2008 发表于 2022-7-8 16:14
试试吧！！！！！

老师，我想自己修改汇总后单元格填充的颜色（原来是红色，修改为绿色或蓝色，黄色），在vba哪里修改，谢谢。

我行我速2008

Sub 导入()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim D, Ar, Br, Cr, f(), Dr
    Dim R%, C%, X%, Y%, X1%, K%, I%, Co%, T
    Dim MyName$
    Dim Wb As Workbook
    T = Timer
    清除
    Set D = CreateObject("scripting.dictionary")
    MyName = Dir(ThisWorkbook.Path & "\", vbDirectory)
    Do While MyName <> ""
        If InStr(MyName, ".xlsx") > 0 Then
            K = K + 1
            ReDim Preserve f(1 To K)
            f(K) = ThisWorkbook.Path & "\" & MyName
        End If
        MyName = Dir
    Loop

    With ActiveSheet
        .Cells.Interior.ColorIndex = xlNone
        C = .Cells(2, Columns.Count).End(xlToLeft).Column
        Ar = .Range("A1").CurrentRegion
        For X = 3 To UBound(Ar)
            D(Ar(X, 1) & Ar(X, 2) & Ar(X, 3) & Ar(X, 4)) = X
        Next X
        For Y = 5 To C Step 5
            For I = 1 To UBound(f)
                ReDim Cr(1 To 1000, 1 To 5)
                K = 0
                If InStr(f(I), Ar(1, Y)) > 0 Then
                    Set Wb = Workbooks.Open(f(I))
                    Br = Wb.Sheets(1).Range("A1").CurrentRegion
                    For X1 = 2 To UBound(Br)
                        If D.Exists(Br(X1, 2) & Br(X1, 3) & Br(X1, 4) & Br(X1, 5)) Then
                            Co = D(Br(X1, 2) & Br(X1, 3) & Br(X1, 4) & Br(X1, 5))
                            Ar(Co, Y) = Br(X1, 2)
                            Ar(Co, Y + 1) = Br(X1, 3)
                            Ar(Co, Y + 2) = Br(X1, 4)
                            Ar(Co, Y + 3) = Br(X1, 5)
                            Ar(Co, Y + 4) = Br(X1, 6)
                        Else
                            K = K + 1
                            Cr(K, 1) = Br(X1, 2)
                            Cr(K, 2) = Br(X1, 3)
                            Cr(K, 3) = Br(X1, 4)
                            Cr(K, 4) = Br(X1, 5)
                            Cr(K, 5) = Br(X1, 6)
                        End If
                    Next X1
                End If
                Wb.Close
                With .Cells(1, 1).Resize(UBound(Ar), UBound(Ar, 2))
                    .Value = Ar
                    With .Borders
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 1
                    End With
                End With
                If K > 0 Then
                    .Cells(UBound(Ar) + 1, Y).Resize(K, 5) = Cr
                   .Cells(UBound(Ar) + 1, Y).Resize(K, 5).Interior.ColorIndex = 35
                End If
            Next I
        Next Y

    End With
    MsgBox Format(Timer - T, "0.00")
    Set Wb = Nothing
    Application.ScreenUpdating = True
End Sub