10，多工作簿多工作表提取數據（Do While）

"10，多工作簿多工作表提取數據（Do While）

"http://club.excelhome.net/viewthread.php?tid=511250&pid=3368549_

&page=1&extra=page%3D1

"年度匯總.xls

Sub ndhz()

Dim Arr, myPath$,myName$, wb As Workbook, sh As Worksheet

Dim m&, funm$,shnm$, col%, i&

Application.ScreenUpdating = False

Set wb = ThisWorkbook

funm = "年度匯總.xls"

myPath =ThisWorkbook.PATH & ""

myName = Dir(myPath& "*.xls")

Do While myName <>"" And myName <> funm

With GetObject(myPath & myName)

Arr = .Sheets("領料").Range("A1").CurrentRegion

For Each sh In wb.Sheets

shnm = sh.Name

sh.Activate

If InStr(shnm, "班") > 0 Then

col = 11

Else

col = 7

End If

For i = 2 To UBound(Arr)

If Arr(i, col) = shnm Then

m = sh.[a65536].End(xlUp).Row + 1

Cells(m, 1).Resize(1, 12) = _

Application.Index(Arr, i, 0)

End If

Next

Next

.Close False

End With

myName = Dir

Loop

Application.ScreenUpdating = True

End Sub

"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":

m = 1

myPath =ThisWorkbook.PATH & ""

myName = Dir(myPath &"*.xls")

Do While myName <>"" And myName <> funm

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("b9:e" & Myr)

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%3D1

"我想要的結果.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& "*.xls")

n = 2

Do While myName <>"" And myName <> funm

With GetObject(myPath & myName)

Set sh = .Sheets("Sheet1")

m = sh.[a65536].End(xlUp).Row

Arr = sh.Range("a2:f" & m)

Cells(n, 1).Resize(m - 1, 6) = Arr

n = n + m - 1

.Close False

End With

myName = Dir

Loop

Sht.Range("a2:f" & n - 1).Borders.LineStyle = 1

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": m = 1

myPath = ThisWorkbook.PATH& ""

myName = Dir(myPath& "*.xls")

Do While myName <>"" And myName <> funm

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("a1:c" & Myr)

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

EndIf

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%3D1

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": m = 1

myPath =ThisWorkbook.PATH & ""

myName = Dir(myPath& "*.xls")

Do While myName <>"" And myName <> funm

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("a1:c" & Myr)

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": n = 1

myPath =ThisWorkbook.PATH & ""

myName = Dir(myPath& "*.xls")

wb.Sheets("匯總").[a2:e100].Clear

Do While myName <>"" And myName <> funm

With GetObject(myPath & myName)

Set wb1 = Workbooks(myName)

Set sh = wb1.Sheets("Sheet1")

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("匯總").Range("a2:e"& n).Borders.LineStyle = 1

Application.ScreenUpdating = True

End Sub

"http://club.excelhome.net/thread-580459-1-1.html"ABC.xls2010-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 &"*.xls")

While Not Len(sh) = 0

If sh <> ThisWorkbook.Name Then

With GetObject(myPath & sh)

Set Sht = .Sheets("Sheet1") "要用set以後才能取到數據

m = Sht.[b65536].End(xlUp).Row

Arr = Sht.Range("b3:e" & m)

Arr1 = Sht.Range("b4:e" & m)

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%3D1

Sub ndhz()

Dim Arr, myPath$,myName$, wb As Workbook, sh As Worksheet

Dim funm$, nm$, n%, wb1As Workbook, r1, col%, Myr&

Application.ScreenUpdating = False

Set wb = ThisWorkbook

funm = "總表.xls": n = 1

myPath =ThisWorkbook.PATH & ""

myName = Dir(myPath& "*.xls")

wb.Sheets("Sheet1").Cells.ClearContents [a2] = "產品名"

Do While myName <>""

If myName <> funm Then

With GetObject(myPath & myName)

nm = Left(myName, Len(myName) - 4)

Set wb1 = Workbooks(myName)

Set sh = wb1.Sheets("Sheet1")

Arr = sh.[a1].CurrentRegion

With wb.Sheets("Sheet1")

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