Set sh = wb1.Sheets(\ Arr = sh.[a1].CurrentRegion With wb.Sheets(\
Set r1 = .Rows(2).Find(nm, , , 1) If Not r1 Is Nothing Then col = r1.Column Else
col = [iv2].End(xlToLeft).Column + 1 Cells(2, col) = nm End If
For i = 2 To UBound(Arr)
Set r1 = .[a:a].Find(Arr(i, 1), , , 1) If Not r1 Is Nothing Then
.Cells(r1.Row, col) = Arr(i, 2) Else
Myr = .[a65536].End(xlUp).Row + 1 .Cells(Myr, 1) = Arr(i, 1) .Cells(Myr, col) = Arr(i, 2) End If Next End With
.Close False End With End If
myName = Dir Loop
Application.ScreenUpdating = True End Sub
11，多工作簿提取指定数据（GetOpenFileName）
‘汇总表.xls
‘http://club.excelhome.net/viewthread.php?tid=511349&pid=3369047&page=1&extra=page=1
Private Sub CommandButton1_Click()
Dim tmpFileName As String, FileNumber As Integer, c As Range
Dim myWorkbook As Workbook, tmpFileList As Variant, tmpFileIndex As Long Dim f As Range ‘上述红字必须声明为Variant，否则下面的Ubound要出错
tmpFileList = Application.GetOpenFilename(\确定文件\If VarType(tmpFileList) = vbBoolean Then Exit Sub
Else
Application.ScreenUpdating = False
Application.StatusBar = \数据处理中，请稍等...\ Application.DisplayAlerts = False Set f = [a65536].End(xlUp)
For tmpFileIndex = 1 To UBound(tmpFileList)
Application.StatusBar = tmpFileIndex & \处理中\ tmpFileName = tmpFileList(tmpFileIndex)
Set myWorkbook = Workbooks.Open(tmpFileName, 0, vbReadOnly) With myWorkbook
Set c = .Worksheets(1).Range(\销售额\'找到B列中带销售额字样的单元格
Set f = f.Offset(1, 0)
f.Value = Left(.Name, Len(.Name) - 4) '填入文件名
f.Offset(0, 1).Value = c.Offset(0, 1).Value '填入销售额的数字 .Close False End With Next tmpFileIndex End If
Application.StatusBar = False Application.DisplayAlerts = True End Sub
12，多工作表汇总（字典）
‘1231228.xls
‘http://club.excelhome.net/thread-518738-1-1.html 模块1：
Public m%, k1
Private Sub Workbook_Open() Dim d, k, t, Myr&, Arr, i&
Set d = CreateObject(\With Sheet3
Myr = .[a65536].End(xlUp).Row Arr = .Range(\ For i = 1 To UBound(Arr) d(Arr(i, 1)) = \ Next
k = d.keys
With Sheet1.[b1].Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(d.keys, \ End With d.RemoveAll
Set d = CreateObject(\ For i = 1 To UBound(Arr) d(Arr(i, 4)) = \ Next m = d.Count k1 = d.keys End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Address <> \Dim d, k, t, Arr, i&, Myr&, x, yf, j&, Arr1 Dim ii&, lj, zb, ljs, cp, j1%, y, jj%
Set d = CreateObject(\yf = Target.Value With Sheet2
Myr = .[a65536].End(xlUp).Row Arr = .Range(\ For i = 1 To UBound(Arr)
x = Arr(i, 1) & \ d(x) = d(x) + Arr(i, 5) Next
k = d.keys t = d.items
ReDim Arr1(1 To m, 1 To 7) For j = 0 To UBound(k1) For j1 = 0 To UBound(k)
y = Val(Split(k(j1), \ cp = Split(k(j1), \
If cp = k1(j) And y = yf Then Arr1(j + 1, 1) = k1(j)
Arr1(j + 1, 3) = t(j1) '本月发货 End If
If cp = k1(j) And y < yf + 1 Then lj = lj + t(j1) '累计发货 End If Next
Arr1(j + 1, 6) = lj '累计发货 lj = 0 Next
End With d.RemoveAll
Set d = CreateObject(\With Sheet3
Myr = .[a65536].End(xlUp).Row Arr = .Range(\ For i = 1 To UBound(Arr)
x = Arr(i, 1) & \ d(x) = d(x) + Arr(i, 5) Next
k = d.keys t = d.items
For j = 0 To UBound(k1) For j1 = 0 To UBound(k)
y = Val(Split(k(j1), \ cp = Split(k(j1), \
If cp = k1(j) And y = yf Then
Arr1(j + 1, 2) = t(j1) '本月指标 For ii = 1 To UBound(k) + 1 zb = zb + t(ii - 1) '本年指标 Next
Arr1(j + 1, 5) = zb '本年指标 zb = 0 Exit For End If Next Next End With d.RemoveAll
Set d = CreateObject(\With Sheet4
Myr = .[a65536].End(xlUp).Row Arr = .Range(\ For i = 1 To UBound(Arr)
x = Arr(i, 1) & \ d(x) = d(x) + Arr(i, 5) Next
k = d.keys t = d.items
For j = 0 To UBound(k1) For j1 = 0 To UBound(k)
y = Val(Split(k(j1), \ cp = Split(k(j1), \
If cp = k1(j) And y = yf Then
Arr1(j + 1, 4) = t(j1) '上年发货 End If
If cp = k1(j) And y < yf + 1 Then ljs = ljs + t(j1) '累计发货 End If Next
Arr1(j + 1, 7) = ljs '累计发货 ljs = 0 Next End With
Sheet1.[c4].Resize(UBound(Arr1), 7).ClearContents Sheet1.[c4].Resize(UBound(Arr1), 7) = Arr1 End Sub
13，多工作表不同产量总重量汇总（字典）
‘http://club.excelhome.net/viewthread.php?tid=523576&pid=3452133&page=1&extra=page=1
‘计算多个表相同名称的总重量0108.xls
Private Sub CommandButton1_Click()
Dim nm$, nm1$, i&, d, st As Worksheet, r1, ad$, sul,t nm = \各机组投产数量\nm1 = \材料调价分类明细\
Set d = CreateObject(\ For i = 3 To [b65536].End(3).Row
d(\‘不重复材料重量置0 Next i
For Each st In Sheets
If st.Name <> nm1 And st.Name <> nm And st.Name <> \And st.Name <> \提示\
Set r1 = Sheets(nm).Cells.Find(st.Name, , , 1) If Not r1 Is Nothing Then
ad = r1.Address ‘表格名的地址
sul = Sheets(nm).Range(ad).Offset(1, 0) ‘投产的数量 If sul <> 0 Then
For i = 3 To st.[b65536].End(3).Row d(\& st.Cells(i, 3)) = d(\& st.Cells(i, 3)) + st.Cells(i, 4) * sul Next i End If End If