VBA Loop refuses to work

[Mari0]

hi,

I am trying to get this macro to run where there is a number in a cell then it takes the main header and the sub header and transposes it then adds the value but for some reason it refuses to work. the loop variable e.g. datarow for example is set at datarow = 3 but it appears as blank and while the loop runs nothing happens.

anyone have any idea?

see below example of macro

Sub Step_2()


Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False


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


'change this to the drive
Const strPath As String = "C:\Users\omar.uni\Desktop\Timesheets"


ChDir strPath
    strExtension = Dir("*.xls*")
    
Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)
      With wkbSource
      LastRow = Sheets("Actual Hours").Cells(Rows.Count, "A").End(xlUp).Row
      Set shtcopy = Sheets("Sheet1") 'IF WORKSHEET NAME CHANGES
      Set shtfinal = Sheets("Sheet4")
        DataRow = 3
    OutRow = 2
    Role1Col = 16
      Do Until shtcopy.Cells(DataRow, "A") = ""
        OutStart = OutRow
        RoleCol = Role1Col
        Do Until shtcopy.Cells(2, RoleCol) = ""
          If shtcopy.Cells(DataRow, RoleCol) > 0 Then
            shtfinal.Cells(OutRow, Role1Col).Value = .shtcopy.Cells(1, Role1Col + VBA.Int((RoleCol - Role1Col) / 3) * 3).Value
            shtfinal.Cells(OutRow, Role1Col + 1).Value = .shtcopy.Cells(2, RoleCol).Value
            shtfinal.Cells(OutRow, Role1Col + 2).Value = .shtcopy.Cells(DataRow, RoleCol).Value
            OutRow = OutRow + 1
          End If
          RoleCol = RoleCol + 1
        Loop
        If OutStart <> OutRow Then
          .shtcopy.Range(.shtcopy.Cells(DataRow, 1), .shtcopy.Cells(DataRow, Role1Col - 1)).Copy .shtfinal.Range(.shtfinal.Cells(OutStart, 1), shtfinal.Cells(OutRow - 1, Role1Col - 1))
        End If
        DataRow = DataRow + 1
      Loop
    End With
    strExtension = Dir()
  Loop


MsgBox ("Step 2 complete move to step 3!")
GoTo Exitsub


Exitsub:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True


End Sub

any help will be greatly appreciated!

 

[Mari0]

Re: VBA Loop refuses to work need help desperately!

Never mind sorted!