VBA to Loop through list of sheets and apply macro

attach please 2 sample files for testing on local drive

Hi, hungryhobo,

give this code a try (untested):

Sub NewWeek_2()
    Dim mywb As Workbook
    Dim wb2 As Workbook
    Dim rngCell As Range
    Dim lngCounter As Long
    Dim lngLast As Long
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    Set mywb = ActiveWorkbook
    Set ws = mywb.ActiveSheet
    lngLast = ws.Cells(Rows.Count, "A").End(xlUp).Row
    
    For lngCounter = 2 To lngLast
      Set wb2 = Workbooks.Open(Filename:="E:\archive\wb" & ws.Cells(lngCounter, "A").Value & ".xlsx")
      With wb2.ActiveSheet
          For Each rngCell In .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
              If Trim(rngCell.Value) <> vbNullString Then rngCell.Value = Trim(rngCell.Value)
          Next rngCell
      End With
      wb2.Close True
    Next lngCounter
    
    Application.Goto ws.Cells(1)
    Application.ScreenUpdating = True
    Set rngCell = Nothing
    Set wb2 = Nothing
    Set ws = Nothing
    Set mywb = Nothing
     
End Sub

Ciao,
Holger

Hi, hungryhobo,

you correct about not looping the sheets in the opened workbook as I misread and wrote code to open several workbooks instead.

Please give this a try:

Sub NewWeek_3()
    Dim myWb As Workbook
    Dim wb2 As Workbook
    Dim rngCell As Range
    Dim lngCounter As Long
    Dim lngLast As Long
    Dim wsAct As Worksheet
    
    Application.ScreenUpdating = False
    Set myWb = ActiveWorkbook
    Set wsAct = myWb.ActiveSheet
    lngLast = wsAct.Cells(Rows.Count, "A").End(xlUp).Row
    
    Set wb2 = Workbooks.Open(Filename:="E:\archive\wb" & wsAct.Range("D2").Value & ".xlsx")
    For lngCounter = 2 To lngLast
      With wb2.Sheets(wsAct.Cells(lngCounter, "A").Value)
          For Each rngCell In .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
              If Trim(rngCell.Value) <> vbNullString Then rngCell.Value = Trim(rngCell.Value)
          Next rngCell
      End With
    Next lngCounter
    wb2.Close True
    
    Application.Goto wsAct.Cells(1)
    Application.ScreenUpdating = True
    Set rngCell = Nothing
    Set wb2 = Nothing
    Set wsAct = Nothing
    Set myWb = Nothing
     
End Sub

Please consider to use this instead of the loop

    For lngCounter = 2 To lngLast
      With wb2.Sheets(wsAct.Cells(lngCounter, "A").Value)
          With .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
              .Value = .Value
          End With
      End With
    Next lngCounter

Ciao,
Holger

Originally Posted by HaHoBe

Hi, hungryhobo,

you correct about not looping the sheets in the opened workbook as I misread and wrote code to open several workbooks instead.


Holger

Thanks for the code, how do I get it to delete sheets not in the list once the loop comes to a blank cell or end of list?

Hi, hungryhobo,

only suggestion would be to have a look at the References at work where a broken link may be found if itīs a truted location and macros are enabled.

Sorry I overread that and just had a look at your code which was showing code to work for Column A.

Change

        With ws2
          For Each rngCell In .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
              If Trim(rngCell.Value) <> vbNullString Then rngCell.Value = Trim(rngCell.Value)
          Next rngCell
        End With

to

        With ws2
          For Each rngCell In .UsedRange
              If Trim(rngCell.Value) <> vbNullString Then rngCell.Value = Trim(rngCell.Value)
          Next rngCell
        End With

Ciao,
Holger

Hi, hungryhobo,

as you may have noticed the code does what itīs supposed to do, and without having a look at your computer at work I think I wonīt be able to determine why the code doesnīt work there.

Ciao,
Holger