Hi All,
Having an issue with the following code.
I have a program that exports data in seperate exelfiles, this can sometimes generate a lot of files (10-20 files)
and I needed a function that can combine these in to one single workbook and with the combined data listed on the same sheet.
Now, my problem is that when using this code and I have all these generated and open excel files direclty from my program the code will only sumiraze one of the open files.
However, If I save the opend excel files locally and then open them again, the code works as it should and save all of them in to the same active work.
I cant find the cause for what is making the diffrence from directly generated open excel to opend files that are saved localy.
Can anyone see the issue or familiar with similar problem?
Code as follow:
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
Any help would be very appreciated.
BR
Fred
Having an issue with the following code.
I have a program that exports data in seperate exelfiles, this can sometimes generate a lot of files (10-20 files)
and I needed a function that can combine these in to one single workbook and with the combined data listed on the same sheet.
Now, my problem is that when using this code and I have all these generated and open excel files direclty from my program the code will only sumiraze one of the open files.
However, If I save the opend excel files locally and then open them again, the code works as it should and save all of them in to the same active work.
I cant find the cause for what is making the diffrence from directly generated open excel to opend files that are saved localy.
Can anyone see the issue or familiar with similar problem?
Code as follow:
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
Any help would be very appreciated.
BR
Fred
