‘http://club.excelhome.net/viewthread.php?tid=629755&page=1#pid4261137 Sub tqsj()
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$ Application.ScreenUpdating = False On Error Resume Next Set Sht1 = ActiveSheet [a2:g1000].ClearContents funm = \提取数据.xls\
myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \
Do While myName <> \ With GetObject(myPath & myName) Set wb = Workbooks(myName) For Each sh In wb.Sheets shnm = sh.Name sh.Activate
pm = sh.[a4].Value
Myr = sh.[a65536].End(xlUp).Row Arr = sh.Range(\ m = m + 1 With Sht1
.Cells(m, 1) = myName .Cells(m, 2) = pm .Cells(m, 3) = shnm
.Cells(m, 4).Resize(UBound(Arr), 4) = Arr End With
m = m + UBound(Arr) - 1 Next
.Close False End With
myName = Dir Loop
Application.ScreenUpdating = True End Sub
‘http://club.excelhome.net/viewthread.php?tid=521786&pid=3439524&page=1&extra=page=1
‘我想要的结果.xls Sub zdgx()
Dim Arr, myPath$, myName$, sh As Worksheet Dim m&, funm$, n&, Sht As Worksheet Application.ScreenUpdating = False
funm = \我想要的结果.xls\ Set Sht = ActiveSheet
Sht.[a2:f1000].ClearContents
Sht.[a2:f1000].Borders.LineStyle = xlNone myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \ n = 2
Do While myName <> \ With GetObject(myPath & myName) Set sh = .Sheets(\
m = sh.[a65536].End(xlUp).Row Arr = sh.Range(\
Cells(n, 1).Resize(m - 1, 6) = Arr n = n + m - 1 .Close False End With
myName = Dir Loop
Sht.Range(\ Application.ScreenUpdating = True End Sub
‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=113181&star=1#1455753 ‘汇总工作表.xls 2010-2-7 Sub ndhz()
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet Application.ScreenUpdating = False On Error Resume Next Set Sht1 = ActiveSheet
funm = \汇总工作表.xls\ myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \
Do While myName <> \ With GetObject(myPath & myName) Set wb = Workbooks(myName) For Each sh In wb.Sheets shnm = sh.Name sh.Activate
Myr = sh.[a65536].End(xlUp).Row Arr = sh.Range(\ For i = 1 To UBound(Arr) If Arr(i, 3) > 50 Then m = m + 1
Sht1.Cells(m, 1).Resize(1, 3) = Application.Index(Arr, i, 0)
Sht1.Cells(m, 4) = Arr(i + 1, 3) Sht1.Cells(m, 5) = Arr(i + 2, 3) Sht1.Cells(m, 6) = shnm End If Next Next
.Close False End With
myName = Dir Loop
Application.ScreenUpdating = True End Sub
‘http://club.excelhome.net/viewthread.php?tid=629755&pid=4261137&page=1&extra=page=1
Sub ndhz()
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet Application.ScreenUpdating = False On Error Resume Next Set Sht1 = ActiveSheet
funm = \汇总工作表.xls\ myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \
Do While myName <> \ With GetObject(myPath & myName) Set wb = Workbooks(myName) For Each sh In wb.Sheets shnm = sh.Name sh.Activate
Myr = sh.[a65536].End(xlUp).Row Arr = sh.Range(\ For i = 1 To UBound(Arr) If Arr(i, 3) > 50 Then m = m + 1
Sht1.Cells(m, 1).Resize(1, 3) = Application.Index(Arr, i, 0) Sht1.Cells(m, 4) = Arr(i + 1, 3) Sht1.Cells(m, 5) = Arr(i + 2, 3) Sht1.Cells(m, 6) = shnm End If Next Next
.Close False End With
myName = Dir Loop
Application.ScreenUpdating = True End Sub
‘http://club.excelhome.net/thread-539493-1-1.html
Sub ndhz() ‘设置工作表在此处要用Sheets(\汇总\格式
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, n%, i&, wb1 As Workbook Application.ScreenUpdating = False Set wb = ThisWorkbook funm = \汇总.xls\
myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \ wb.Sheets(\汇总\
Do While myName <> \ With GetObject(myPath & myName) Set wb1 = Workbooks(myName) Set sh = wb1.Sheets(\ m = sh.[a65536].End(xlUp).Row With wb.Sheets(\汇总\ n = n + 1
.Cells(n, 1) = sh.[b2].Value .Cells(n, 2) = sh.[c2].Value
.Cells(n, 3) = Application.Sum(sh.[e2].Resize(m - 1, 1)) .Cells(n, 4) = Application.Sum(sh.[f2].Resize(m - 1, 1)) .Cells(n, 5) = Application.Sum(sh.[g2].Resize(m - 1, 1)) End With .Close False End With
myName = Dir Loop
wb.Sheets(\汇总\ Application.ScreenUpdating = True End Sub
'http://club.excelhome.net/thread-580459-1-1.html ‘ABC.xls 2010-5-28 Sub dgzbsj()
Dim Arr, i&, sh$, n&, myPath$, shnm$, nm$, ad$ Dim Sht As Worksheet, m&, Arr1, r1 On Error Resume Next
Application.ScreenUpdating = False
myPath = ThisWorkbook.Path & \ sh = Dir(myPath & \ While Not Len(sh) = 0
If sh <> ThisWorkbook.Name Then With GetObject(myPath & sh)
Set Sht = .Sheets(\ ‘要用set以后才能取到数据 m = Sht.[b65536].End(xlUp).Row Arr = Sht.Range(\ Arr1 = Sht.Range(\ shnm = Left(sh, Len(sh) - 4) For i = 1 To UBound(Arr, 2) nm = Arr(1, i)
Sheets(nm).Activate
Set r1 = Cells.Find(shnm, , , 1) If Not r1 Is Nothing Then
Range(r1.Address).Offset(1, 0).Resize(UBound(Arr1), 1) = Application.Index(Arr1, 0, i) End If Next End With End If sh = Dir Wend
Application.ScreenUpdating = True End Sub
‘2011-7-5
‘http://club.excelhome.net/viewthread.php?tid=738176&pid=5011219&page=1&extra=page=1
Sub ndhz()
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim funm$, nm$, n%, wb1 As Workbook, r1, col%, Myr& Application.ScreenUpdating = False Set wb = ThisWorkbook
funm = \总表.xls\
myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \
wb.Sheets(\ [a2] = \产品名\
Do While myName <> \
If myName <> funm Then
With GetObject(myPath & myName)
nm = Left(myName, Len(myName) - 4) Set wb1 = Workbooks(myName)