Open Workbooks Loop through all Sheets

user_19293892 0
Viewed 44

I am trying to run a command to open all workbooks from a query. Once open I am looking to edit the same cells in each tab for each workbook. The code below, works to open, and edit each workbook in the query when trying to update to run through each active sheet in the workbooks it will only update the first sheet. The second set is what I have tried to have it loop through each sheet.

Open and update the first active sheet in each workbook

Sub UpdateMetrics()
 Dim wb As Workbook 
      For Each Cell In Selection     
          Set wb = Workbooks.Open(Cell.Value) 
              Range("A1").Value = "Test" 
          wb.Save
         wb.Close
     Next
End Sub

Loop through each sheet:

Sub UpdateMetricsTest()
    Dim wb As Workbook
    Dim ws As Worksheet
    For Each Cell In Selection
        Set wb = Workbooks.Open(Cell.Value) 
        For Each ws In Worksheets
            Range("A1").Value = "Test"
        Next ws 
    Next 
End Sub
vba excel
1 Answers

Loop Through Each Worksheet of Each Workbook

  • This will write a value (Test) into the same cell (A1) of each worksheet of each file (workbook) that is opened. The list of the file paths (e.g. C:\Test\Test1.xlsx) is in a column (A; more accurately A2:ALastRow) of a worksheet (Sheet1) of the workbook containing this code (ThisWorkbook).
Option Explicit

Sub UpdateMetrics()
    
    ' Source (read from)
    Const sName As String = "Sheet1"
    Const sCol As String = "A"
    Const sfRow As Long = 2
    ' Destination (write to)
    Const dCellAddress As String = "A1"
    Const dCellValue As String = "Test"
    
    ' Reference the source (one-column) range containing the file paths.
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sws.Cells(sfRow, sCol), _
        sws.Cells(sws.Rows.Count, sCol).End(xlUp)) ' ('A2:ALastRow')
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dFilePath As String
    
    ' Loop through the cells of the source range.
    For Each sCell In srg.Cells
        dFilePath = CStr(sCell.Value) ' Tolerate error values by using 'CStr'.
        If Len(dFilePath) > 0 Then ' cell is not blank
            If Len(Dir(dFilePath)) > 0 Then ' file exists
                On Error Resume Next ' Attempt to open the file:
                    Set dwb = Workbooks.Open(dFilePath)
                On Error GoTo 0
                If Not dwb Is Nothing Then ' file was opened
                    ' Loop through the worksheets in the current workbook...
                    For Each dws In dwb.Worksheets
                        ' ... and write the value to each worksheet's cell.
                        dws.Range(dCellAddress).Value = dCellValue
                    Next dws
                    dwb.Close SaveChanges:=True
                    Set dwb = Nothing
                'Else ' file was not opened; do nothing
                End If
            'Else ' file does not exist; do nothing
            End If
        'Else ' cell is blank; do nothing
        End If
    Next sCell
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Metrics updated.", vbInformation
    
End Sub
user_98140690
Related