Using 'With Workbook' and 'Do while' loop through multi workbook

[KNKN9]

Hi ...

I have multiple workbooks saved in a folder and the code below seems to only work for my first file. However, I need it to work for all the files in the folder but can't seem to see where I have gone wrong.

Dim wkbDest As Workbook
Dim wkbSource As Workbook
Dim shtcopy As Worksheet
Dim shtfinal As Worksheet
Dim LastRow As Long




DataRow = 3
OutRow = 2
Role1Col = 13


Const strPath As String = "filename"


ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)


With wkbSource
     LastRow = .Sheets("Actual Hours").Cells(10000, 1).End(xlUp).Row
   Do Until .Sheets("Sheet1").Cells(DataRow, 1) = ""
    OutStart = OutRow
    RoleCol = Role1Col
    Do Until .Sheets("Sheet1").Cells(2, RoleCol) = ""
            If .Sheets("Sheet1").Cells(DataRow, RoleCol) > 0 Then
            .Sheets("Sheet4").Cells(OutRow, Role1Col) = .Sheets("Sheet1").Cells(1, Role1Col + VBA.Int((RoleCol - Role1Col) / 3) * 3)
            .Sheets("Sheet4").Cells(OutRow, Role1Col + 1) = .Sheets("Sheet1").Cells(2, RoleCol)
            .Sheets("Sheet4").Cells(OutRow, Role1Col + 2) = .Sheets("Sheet1").Cells(DataRow, RoleCol)
            OutRow = OutRow + 1
            End If
            RoleCol = RoleCol + 1
            Loop
            If OutStart <> OutRow Then
            .Sheets("Sheet1").Range(.Sheets("Sheet1").Cells(DataRow, 1), .Sheets("Sheet1").Cells(DataRow, Role1Col - 1)).Copy .Sheets("Sheet4").Range(.Sheets("Sheet4").Cells(OutStart, 1), Sheets("Sheet4").Cells(OutRow - 1, Role1Col - 1))
            End If
            DataRow = DataRow + 1
            Loop
            .Close savechanges:=True
        End With
        strExtension = Dir
    Loop

 

[DanteAmor]

Try this

Sub Multi_WorkBook()
  Dim wkbDest As Workbook, wkbSource As Workbook
  Dim shtcopy As Worksheet, shtfinal As Worksheet
  Dim LastRow As Long, DataRow As Long, Role1Col As Long, OutRow As Long
  Dim strExtension, OutStart As Long, RoleCol As Long
  
  
  Const strPath As String = "C:\trabajo\"
  strExtension = Dir(strPath & "*.xls*")
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)
[COLOR=#0000ff]    DataRow = 3[/COLOR]
[COLOR=#0000ff]    OutRow = 2[/COLOR]
[COLOR=#0000ff]    Role1Col = 13[/COLOR]
    With wkbSource
      LastRow = .Sheets("Actual Hours").Cells(Rows.Count, "A").End(xlUp).Row
      Do Until .Sheets("Sheet1").Cells(DataRow, "A") = ""
        OutStart = OutRow
        RoleCol = Role1Col
        Do Until .Sheets("Sheet1").Cells(2, RoleCol) = ""
          If .Sheets("Sheet1").Cells(DataRow, RoleCol) > 0 Then
            .Sheets("Sheet4").Cells(OutRow, Role1Col) = .Sheets("Sheet1").Cells(1, Role1Col + VBA.Int((RoleCol - Role1Col) / 3) * 3)
            .Sheets("Sheet4").Cells(OutRow, Role1Col + 1) = .Sheets("Sheet1").Cells(2, RoleCol)
            .Sheets("Sheet4").Cells(OutRow, Role1Col + 2) = .Sheets("Sheet1").Cells(DataRow, RoleCol)
            OutRow = OutRow + 1
          End If
          RoleCol = RoleCol + 1
        Loop
        If OutStart <> OutRow Then
          .Sheets("Sheet1").Range(.Sheets("Sheet1").Cells(DataRow, 1), .Sheets("Sheet1").Cells(DataRow, Role1Col - 1)).Copy .Sheets("Sheet4").Range(.Sheets("Sheet4").Cells(OutStart, 1), Sheets("Sheet4").Cells(OutRow - 1, Role1Col - 1))
        End If
        DataRow = DataRow + 1
      Loop
      .Close savechanges:=True
    End With
    strExtension = Dir()
  Loop
End Sub

 

[KNKN9]

This works perfect!

Thanks

Try this

Sub Multi_WorkBook()
  Dim wkbDest As Workbook, wkbSource As Workbook
  Dim shtcopy As Worksheet, shtfinal As Worksheet
  Dim LastRow As Long, DataRow As Long, Role1Col As Long, OutRow As Long
  Dim strExtension, OutStart As Long, RoleCol As Long
  
  
  Const strPath As String = "C:\trabajo\"
  strExtension = Dir(strPath & "*.xls*")
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)
[COLOR=#0000ff]    DataRow = 3[/COLOR]
[COLOR=#0000ff]    OutRow = 2[/COLOR]
[COLOR=#0000ff]    Role1Col = 13[/COLOR]
    With wkbSource
      LastRow = .Sheets("Actual Hours").Cells(Rows.Count, "A").End(xlUp).Row
      Do Until .Sheets("Sheet1").Cells(DataRow, "A") = ""
        OutStart = OutRow
        RoleCol = Role1Col
        Do Until .Sheets("Sheet1").Cells(2, RoleCol) = ""
          If .Sheets("Sheet1").Cells(DataRow, RoleCol) > 0 Then
            .Sheets("Sheet4").Cells(OutRow, Role1Col) = .Sheets("Sheet1").Cells(1, Role1Col + VBA.Int((RoleCol - Role1Col) / 3) * 3)
            .Sheets("Sheet4").Cells(OutRow, Role1Col + 1) = .Sheets("Sheet1").Cells(2, RoleCol)
            .Sheets("Sheet4").Cells(OutRow, Role1Col + 2) = .Sheets("Sheet1").Cells(DataRow, RoleCol)
            OutRow = OutRow + 1
          End If
          RoleCol = RoleCol + 1
        Loop
        If OutStart <> OutRow Then
          .Sheets("Sheet1").Range(.Sheets("Sheet1").Cells(DataRow, 1), .Sheets("Sheet1").Cells(DataRow, Role1Col - 1)).Copy .Sheets("Sheet4").Range(.Sheets("Sheet4").Cells(OutStart, 1), Sheets("Sheet4").Cells(OutRow - 1, Role1Col - 1))
        End If
        DataRow = DataRow + 1
      Loop
      .Close savechanges:=True
    End With
    strExtension = Dir()
  Loop
End Sub

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.