Problem with compling open workbooks in to one

Question

I need to compile data from several open excel workbooks in to one workbook and list in one sheet. The excels are generated from a program that just open these up, they are not stored locally. I have managed to compile a code that should do this, but It only works if I first save the generated workbooks to a local folder and then open them again.

If I just run the code when the are directly open by the system it only compile one of the workbooks, not the rest.

I cant find the reason for why it does this. Could it be the format? when saved they are with file extension .xlsx

The code looks like this, (sorry for not so compact code)

Sub CombineMultipleSheetsToExisting()
   On Error GoTo eh
'declare variables to hold the objects required
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim rngEnd As String
   Dim rngSource As Range
'set the active workbook object for the destination book
   Set wbDestination = ActiveWorkbook
'get the name of the active file
   strDestName = wbDestination.Name
'turn off the screen updating to speed things up
   Application.ScreenUpdating = False
'first create new destination worksheet in your Active workbook
   Application.DisplayAlerts = False
'resume next error in case sheet doesn't exist
   On Error Resume Next
   ActiveWorkbook.Sheets("Consolidation").Delete
'reset error trap to go to the error trap at the end
   On Error GoTo eh
   Application.DisplayAlerts = True
'add a new sheet to the workbook
   With ActiveWorkbook
      Set wsDestination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
      wsDestination.Name = "Consolidation"
   End With
'now loop through each of the workbooks open to get the data
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
            For Each sh In wbSource.Worksheets
'get the number of rows in the sheet
               sh.Activate
               ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
               iRws = ActiveCell.Row
               iCols = ActiveCell.Column
               rngEnd = sh.Cells(iRws, iCols).Address
               Set rngSource = sh.Range("A1:" & rngEnd)
'find the last row in the destination sheet
               wbDestination.Activate
               Set wsDestination = ActiveSheet
               wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
               totRws = ActiveCell.Row
'check if there are enough rows to paste the data
               If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
                  MsgBox "There are not enough rows to place the data in the Consolidation worksheet."
                  GoTo eh
               End If
'add a row to paste on the next row down if you are not in row 1
               If totRws <> 1 Then totRws = totRws + 1
               rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
           Next sh
         End If
   Next wb
'now close all the open files except the one you want
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb
 
'clean up the objects to release the memory
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'turn on the screen updating when complete
   Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub

Thanks in advance.

Best regards Fred