VBA引用其他工作簿问题

luketools

希望用VBA实现两个功能：

1.当销售数据工作簿增加新的工作表时，新增的工作表名称自动添加到汇总表的最下方；
2.因为销售数据中的“汇总”有一列需要引用外部工作簿【进货数据】的内容，使用的是VLOOKUP函数，但进货数据有设置密码，每次更新数据时都要输入密码比较麻烦，可否用VBA设置不用输入密码自动引用过来。现在附件中进货数据工作簿密码是123。

3190496160

Sub 汇总匹配()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("汇总")
    .UsedRange.Offset(1).Borders.LineStyle = 0
    .UsedRange.Offset(1) = Empty
    ar = .Range("a1:i100")
    For j = 3 To 8
        d(ar(1, j)) = j
    Next j
    k = 1
    For Each sh In Sheets
        If sh.Index > 1 Then
            k = k + 1
            ar(k, 1) = k - 1
            ar(k, 2) = sh.Name
            d(ar(k, 2)) = k
            br = sh.[a1].CurrentRegion
            For i = 2 To UBound(br)
                If br(i, 2) <> "" Then
                    lh = d(br(i, 2))
                    If lh <> "" Then
                        ar(k, lh) = ar(k, lh) + br(i, 3)
                    End If
                End If
            Next i
        End If
    Next sh
    f = Dir(ThisWorkbook.Path & "\进货数据.xls*")
    If f = "" Then MsgBox "找不到进货数据文件！": End
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, , True, , "123")
    With wb.Worksheets(1)
        br = .[a1].CurrentRegion
    End With
    wb.Close False
    For i = 2 To UBound(br)
        xh = d(br(i, 2) & "")
        If xh <> "" Then
            ar(xh, 9) = br(i, 3)
        End If
    Next i
    .[a1].Resize(k, UBound(ar, 2)) = ar
    .[a1].Resize(k, UBound(ar, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

新建文件夹.rar (14.97 KB, 下载次数: 7)

2024-3-22 10:01 上传

点击文件名下载附件

ykcbf1100

汇总表结构我改了一下，因为你年份和客户都会扩展的。不用vlookup了。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.22
   
2.     Dim arr, brr
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set d2 = CreateObject("Scripting.Dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("汇总")
   
9.     p = ThisWorkbook.Path
   
10.     f = p & "\进货数据.xls"
    
11.     mm = "123"
    
12.     Set wb = Workbooks.Open(f, 0, False, , mm, mm)
    
13.     With wb.Sheets("Sheet1")
    
14.         arr = .UsedRange
    
15.         wb.Close False
    
16.     End With
    
17.     For i = 2 To UBound(arr)
    
18.         d1(arr(i, 2)) = arr(i, 3)
    
19.     Next
    
20.     With ws
    
21.         For Each sht In .Sheets
    
22.             If sht.Name <> sh.Name Then
    
23.                 With sht
    
24.                     r = .Cells(Rows.Count, 2).End(3).Row
    
25.                     arr = .[a1].Resize(r, 6)
    
26.                     For i = 2 To UBound(arr)
    
27.                         d2(arr(i, 2)) = ""
    
28.                         s = .Name & "|" & arr(i, 2)
    
29.                         For j = 3 To UBound(arr, 2)
    
30.                             d(s) = d(s) + arr(i, j)
    
31.                         Next
    
32.                     Next
    
33.                 End With
    
34.             End If
    
35.         Next
    
36.         ReDim brr(1 To d1.Count, 1 To 3 + d2.Count)
    
37.         For Each k In d1.keys
    
38.             m = m + 1
    
39.             brr(m, 1) = m
    
40.             brr(m, 2) = k
    
41.             brr(m, 3) = d1(k)
    
42.         Next
    
43.         With sh
    
44.             .UsedRange.Offset(1, 3).Clear
    
45.             .[d1].Resize(1, d2.Count) = d2.keys
    
46.             .[a2].Resize(m, 3 + d2.Count) = brr
    
47.             arr = .UsedRange
    
48.             With .UsedRange
    
49.                 .Borders.LineStyle = 1
    
50.                 .HorizontalAlignment = xlCenter
    
51.                 .VerticalAlignment = xlCenter
    
52.             End With
    
53.             For i = 2 To UBound(arr)
    
54.                 For j = 4 To UBound(arr, 2)
    
55.                     s = arr(i, 2) & "|" & arr(1, j)
    
56.                     If d.exists(s) Then
    
57.                         arr(i, j) = d(s)
    
58.                     End If
    
59.                 Next
    
60.             Next
    
61.             .UsedRange = arr
    
62.         End With
    
63.     End With
    
64.     Set d = Nothing
    
65.     Application.ScreenUpdating = True
    
66.     MsgBox "OK！"
    
67. End Sub
    

复制代码