循環遍歷許多工作簿，循環遍歷第一個和第二個工作表，然後將單元複製/粘貼到工作簿中

「新的VBA用戶，Excel 2010和我在同一個文件夾中有幾個成本估算工作簿。想要循環遍歷所有工作簿，然後循環遍歷第一個和第二個工作表，然後複製並最終粘貼特定單元格的值。循環遍歷許多工作簿，循環遍歷第一個和第二個工作表，然後將單元複製/粘貼到工作簿中

我已將以下幾個來源的某些片斷拼湊起來，目前只有第一個「If 「循環工作表」Distro Sheet「似乎在抓取數據，第二個」If「循環用於」執行估計「似乎絕不會粘貼任何單元格？我試着標記前兩個工作表，使用數組，並使用」Case 「聲明，這些方法都不起作用，任何想法都將不勝感激！」

Sub GatherData() 

Dim wkbkorigin As Workbook 
Dim originsheet As Worksheet 
Dim destsheet As Worksheet 

Dim ResultRow As Long 
Dim Fname As String 
Dim RngDest As Range 
Dim ws As Worksheet 

Set destsheet = ThisWorkbook.Worksheets("Project Cost Tracker") 
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).EntireRow 
Fname = Dir(ThisWorkbook.Path & "/*.xlsx") 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

Do While Fname <> "" And Fname <> ThisWorkbook.Name 
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname) 

     For Each ws In wkbkorigin.Worksheets 

        If ws.Name = "Distro Sheet" Then 

         RngDest.Cells(6, 1).Value = ws.Range("C8").Value 
         RngDest.Cells(6, 5).Value = ws.Range("H8").Value 
         RngDest.Cells(5, 2).Value = ws.Range("C10").Value 
         RngDest.Cells(7, 1).Value = ws.Range("C15").Value 
         RngDest.Cells(8, 1).Value = ws.Range("C16").Value 
         RngDest.Cells(9, 1).Value = ws.Range("C17").Value 
         RngDest.Cells(10, 1).Value = ws.Range("C18").Value 
         RngDest.Cells(11, 1).Value = ws.Range("C19").Value 
         RngDest.Cells(7, 5).Value = ws.Range("D20").Value 
         RngDest.Cells(8, 5).Value = ws.Range("D21").Value 
         RngDest.Cells(9, 5).Value = ws.Range("D22").Value 
         RngDest.Cells(10, 5).Value = ws.Range("D23").Value 
         RngDest.Cells(11, 5).Value = ws.Range("D24").Value 

        End If 

        If ws.Name = "Execution Estimate" Then 

         RngDest.Cells(8, 10).Value = ws.Range("J99").Value 
         RngDest.Cells(9, 10).Value = ws.Range("J157").Value 
         RngDest.Cells(10, 10).Value = ws.Range("J186").Value 

        End If 

     Set RngDest = RngDest.Offset(1, 0) 

     Next ws 

wkbkorigin.Close SaveChanges:=False 
Fname = Dir() 

Loop 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 

End Sub

來源

2017-07-28 A. Staton73

您是否嘗試過逐行調試器？ – SandPiper

@SandPiper是的，變量ws貫穿每張表，因爲它應該，但在表＃2「執行估計」沒有任何值填充我的彙總工作簿。似乎只有選擇工作表而不是所有工作表都有更好的方法嗎？感謝您的反饋！ –

當你到達第二張表時，'ws.Name'的值是多少？是「執行估計」嗎？（確切情況下，沒有額外的空格，確切的拼寫）？（即，當你逐句通過代碼時，它是否實際將步驟**轉換爲**第二個If語句？） – YowE3K

這裏是更正後的代碼..和經驗教訓，使用調試器和跟蹤重要變量。

Sub GatherData() 

     Dim wkbkorigin As Workbook 
     Dim originsheet As Worksheet 
     Dim destsheet As Worksheet 

     Dim ResultRow As Long 
     Dim Fname As String 
     Dim RngDest As Range 
     Dim ws As Worksheet 

     Set destsheet = ThisWorkbook.Worksheets("Project Cost Tracker") 
     Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).EntireRow 
     Fname = Dir(ThisWorkbook.Path & "/*.xlsx") 

     Application.ScreenUpdating = False 
     Application.DisplayAlerts = False 

     Do While Fname <> "" And Fname <> ThisWorkbook.Name 
     Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname) 

     For Each ws In wkbkorigin.Worksheets 

        If ws.Name = "Distro Sheet" Then 

         RngDest.Cells(6, 1).Value = ws.Range("C8").Value 
         RngDest.Cells(6, 5).Value = ws.Range("H8").Value 
         RngDest.Cells(5, 2).Value = ws.Range("C10").Value 
         RngDest.Cells(7, 1).Value = ws.Range("C15").Value 
         RngDest.Cells(8, 1).Value = ws.Range("C16").Value 
         RngDest.Cells(9, 1).Value = ws.Range("C17").Value 
         RngDest.Cells(10, 1).Value = ws.Range("C18").Value 
         RngDest.Cells(11, 1).Value = ws.Range("C19").Value 
         RngDest.Cells(7, 5).Value = ws.Range("D20").Value 
         RngDest.Cells(8, 5).Value = ws.Range("D21").Value 
         RngDest.Cells(9, 5).Value = ws.Range("D22").Value 
         RngDest.Cells(10, 5).Value = ws.Range("D23").Value 
         RngDest.Cells(11, 5).Value = ws.Range("D24").Value 

        End If 

        If ws.Name = "Execution Estimate " Then 

         RngDest.Cells(8, 10).Value = ws.Range("J99").Value 
         RngDest.Cells(9, 10).Value = ws.Range("J157").Value 
         RngDest.Cells(10, 10).Value = ws.Range("J186").Value 

        End If 

     Set RngDest = RngDest.Offset(1, 0) 

     Next ws 

    wkbkorigin.Close SaveChanges:=False 
    Fname = Dir() 

    Loop 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 

    End Sub

來源

2017-07-29 00:25:33

所以，只是第一張和第二張，對嗎？

wks.Index = 1 
wks.Index = 2

該代碼應該看起來像這樣。。。

objXL.Visible = True 
Set wkb = objXL.Workbooks.Open(strPathFile) 
For Each wks In wkb.Worksheets 
    If wks.Index = 1 or wks.Index = 2 Then 
     NeedThisSheet = wks.Name & "!" 
     ' THIS IS FOR IMPORTING DATA INTO ACCESS 
     DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, blnHasFieldNames, NeedThisSheet 
    End If 
Next 
wkb.Close

來源

2017-07-29 02:08:04 ryguy72

循環遍歷許多工作簿，循環遍歷第一個和第二個工作表，然後將單元複製/粘貼到工作簿中

回答

相關問題