En boucle dans de nombreux classeurs, bouclez uniquement les première et deuxième feuilles de calcul, puis copiez/collez des cellules dans un classeur

Question

"Nouvel utilisateur VBA, Excel 2010, et j'ai plusieurs classeurs d'estimation des coûts dans le même dossier. Je souhaite parcourir tous les classeurs, puis parcourir uniquement les première et deuxième feuilles de calcul, puis copier et coller les valeurs finales de cellules spécifiques

J'ai rassemblé plusieurs extraits de plusieurs sources dans le texte ci-dessous. "boucle pour la feuille de calcul" Distro Sheet "semble être saisir des données.La deuxième boucle" If "pour" Execution Estimation "ne semble jamais coller des cellules? J'ai essayé de marquer les deux premières feuilles de calcul, utilisé un tableau, et utilisé un "déclaration Aucune de ces méthodes n'a fonctionné Aucune idée serait grandement appréciée ! "

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 

Answer 1

Voici le code corrigé .. et leçon apprise pour utiliser le débogueur et suivre les variables significatives.

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 

Answer 2

Donc, juste la première et deuxième feuille, non?

wks.Index = 1 
wks.Index = 2 

Le code devrait ressembler à ceci. . .

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