How to do consolidation of workbooks, a little twist.

[palm of thoughts]

Hi there!

I still have a problem with consolidation of workbooks.

Scenario:

I am working in HQ and at the end of each month, every branch under my care will submit an excel workbook to me. Inside this are two worksheets (worksheet 1 and worksheet 2 for convenience). Both have standard headers and rows and rows of data. Upon receipt, I will keep all these files in a folder called "Oct06" (and Nov06 etc for future mths)

Problem:

I'm not able to find an easy way to consolidate all the various worksheet 1 into one master worksheet. I need this so as to generate a pivot table. At the same time, I need to consolidate all the worksheet 2 also for the same purpose.


Hope anyone can offer me an easy way to resolve this problem. Thanks in advance for your kind act!

Rgds
P.O.T

 

[agihcam]

try this code ( untested );
open new workbook and paste this code into standard module.

Sub consolidate()
ActiveWorkbook.Sheets(1).Cells.Delete
ActiveWorkbook.Sheets(2).Cells.Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False

    'dimension variables
    Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet
    Dim ws1 As Worksheet, Ws2 As Worksheet, i As Long, Pos As Long
    Dim Folder As String, File As String, Path As String
    'folder to loop through
    Folder = "C:\Oct06" 'changed as needed
    'set destination info
    Set wsDest1 = ActiveWorkbook.Sheets(1) 'change as needed
    Set wsDest2 = ActiveWorkbook.Sheets(2) 'change as needed
    'Start FileSearch
    With Application.FileSearch
        .LookIn = Folder
        .Filename = "*.xls"
        .FileType = msoFileTypeExcelWorkbooks
        .SearchSubFolders = False
        .Execute
        If .Execute > 0 Then
            'loop through all found files
            For i = 1 To .FoundFiles.Count
                'set incidental variables
                Pos = InStrRev(.FoundFiles(i), "\")
                File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos)
                Path = Left(.FoundFiles(i), Pos)
                'check if workbook is open.  if so, set variable to it, else open it
                If IsWbOpen(File) Then
                    Set wb = Workbooks(File)
                Else
                    Set wb = Workbooks.Open(Path & File)
                End If
                'set worksheets to copy data from
                Set ws1 = wb.Sheets("Sheet1")
                Set ws2 = wb.Sheets("Sheet2")
                'copy data
                ws1.Range("A1:AA1000").Copy  'change the range to copy
                With wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    .PasteSpecial xlValues
                    .PasteSpecial xlFormats
                End With

		ws2.Range("A1:AA1000").Copy  'change the range to copy
                With wsDest2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    .PasteSpecial xlValues
                    .PasteSpecial xlFormats
                End With
                wb.Close
            Next i
        End If
    End With
    
    Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing
    Set Ws2 = Nothing: Set wb = Nothing

Application.ScreenUpdating = true
Application.DisplayAlerts = true
End Sub
Function IsWbOpen(wbName As String) As Boolean
    On Error Resume Next
    IsWbOpen = Len(Workbooks(wbName).Name)
End Function

 

[palm of thoughts]

Hi Agihcam

Thanks for your help. I did try and here's my feedback.

The macro run well, but later, an error as follows:

"Run Time error 1004. This operation requires the merged cell to be identically sized". When debug, it points to this line

.PasteSpecial xlValues


For your info, as a test, I tried the above macro on two identical workbooks (i just changed one of the name) in a folder. So its unlikely that the data should have different sizes.

Hope you can help, thanks!

 

[palm of thoughts]

Oh one more observation.

The problem could have resulted when the macro tried to copy the headers from the second workbook. The macro was successful in consolidating from the first workbook but stopped when reaching the second. This may have caused the problem

Perhaps one way is to prevent the macro from copying the first row of each worksheet (the headers). Is this possible?

 

[agihcam]

try running the code without the headers first then we will add later on.this assume that the header was in row #1. post back the correct row # for the headers.

Sub consolidate() 
ActiveWorkbook.Sheets(1).Cells.Delete 
ActiveWorkbook.Sheets(2).Cells.Delete 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

    'dimension variables 
    Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet 
    Dim ws1 As Worksheet, Ws2 As Worksheet, i As Long, Pos As Long 
    Dim Folder As String, File As String, Path As String 
    'folder to loop through 
    Folder = "C:\Oct06" 'changed as needed 
    'set destination info 
    Set wsDest1 = ActiveWorkbook.Sheets(1) 'change as needed 
    Set wsDest2 = ActiveWorkbook.Sheets(2) 'change as needed 
    'Start FileSearch 
    With Application.FileSearch 
        .LookIn = Folder 
        .Filename = "*.xls" 
        .FileType = msoFileTypeExcelWorkbooks 
        .SearchSubFolders = False 
        .Execute 
        If .Execute > 0 Then 
            'loop through all found files 
            For i = 1 To .FoundFiles.Count 
                'set incidental variables 
                Pos = InStrRev(.FoundFiles(i), "\") 
                File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos) 
                Path = Left(.FoundFiles(i), Pos) 
                'check if workbook is open.  if so, set variable to it, else open it 
                If IsWbOpen(File) Then 
                    Set wb = Workbooks(File) 
                Else 
                    Set wb = Workbooks.Open(Path & File) 
                End If 
                'set worksheets to copy data from 
                Set ws1 = wb.Sheets("Sheet1") 
                Set ws2 = wb.Sheets("Sheet2") 
                'copy data 
                ws1.Range("A2:AA1000").Copy  'change the range to copy 
                With wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(1) 
                    .PasteSpecial xlValues 
                    .PasteSpecial xlFormats 
                End With 

      ws2.Range("A2:AA1000").Copy  'change the range to copy 
                With wsDest2.Cells(Rows.Count, 1).End(xlUp).Offset(1) 
                    .PasteSpecial xlValues 
                    .PasteSpecial xlFormats 
                End With 
                wb.Close 
            Next i 
        End If 
    End With 
    
    Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing 
    Set Ws2 = Nothing: Set wb = Nothing 

Application.ScreenUpdating = true 
Application.DisplayAlerts = true 
End Sub 
Function IsWbOpen(wbName As String) As Boolean 
    On Error Resume Next 
    IsWbOpen = Len(Workbooks(wbName).Name) 
End Function

 

[palm of thoughts]

agihcam, the macro worked fine! It was indeed caused by the header. Thanks for your wonderful help, you couldn't imagine the manpower saved from this enhancement you suggested!


Btw, how can i just add the header automatically on both sheets instead of inserting it manually once the macro is completed? Is there anyway i can insert this in the code you provided below.

 

[agihcam]

Hi -
if the headers was in row#1, then you can the code below ( see commented line ).

Sub consolidate() 
ActiveWorkbook.Sheets(1).Cells.Delete 
ActiveWorkbook.Sheets(2).Cells.Delete 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

    'dimension variables 
    Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet 
    Dim ws1 As Worksheet, Ws2 As Worksheet, i As Long, Pos As Long 
    Dim Folder As String, File As String, Path As String 
    'folder to loop through 
    Folder = "C:\Oct06" 'changed as needed 
    'set destination info 
    Set wsDest1 = ActiveWorkbook.Sheets(1) 'change as needed 
    Set wsDest2 = ActiveWorkbook.Sheets(2) 'change as needed 
    'Start FileSearch 
    With Application.FileSearch 
        .LookIn = Folder 
        .Filename = "*.xls" 
        .FileType = msoFileTypeExcelWorkbooks 
        .SearchSubFolders = False 
        .Execute 
        If .Execute > 0 Then 
            'loop through all found files 
            For i = 1 To .FoundFiles.Count 
                'set incidental variables 
                Pos = InStrRev(.FoundFiles(i), "\") 
                File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos) 
                Path = Left(.FoundFiles(i), Pos) 
                'check if workbook is open.  if so, set variable to it, else open it 
                If IsWbOpen(File) Then 
                    Set wb = Workbooks(File) 
                Else 
                    Set wb = Workbooks.Open(Path & File) 
                End If 
                'set worksheets to copy data from 
                Set ws1 = wb.Sheets("Sheet1") 
                Set ws2 = wb.Sheets("Sheet2") 
                'copy data 
                ws1.Range("A2:AA1000").Copy  'change the range to copy 
                With wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(1) 
                    .PasteSpecial xlValues 
                    .PasteSpecial xlFormats 
                End With 

      ws2.Range("A2:AA1000").Copy  'change the range to copy 
                With wsDest2.Cells(Rows.Count, 1).End(xlUp).Offset(1) 
                    .PasteSpecial xlValues 
                    .PasteSpecial xlFormats 
                End With 
                wb.Close 
            Next i 
        End If 
    End With 
    
    Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing 
    Set Ws2 = Nothing: Set wb = Nothing 

'this line of code will add heading for both sheets1 and sheets2
'adjust as needed
sheets(1).range("a1").resize(,5).value = array("H1","H2","H3","H4","H5")
sheets(2).range("a1").resize(,5).value = array("H1","H2","H3","H4","H5")

Application.ScreenUpdating = true 
Application.DisplayAlerts = true 
End Sub 
Function IsWbOpen(wbName As String) As Boolean 
    On Error Resume Next 
    IsWbOpen = Len(Workbooks(wbName).Name) 
End Function

 

[rrmando]

Hello. I'm trying to use this code to consolidate separate workbooks all located in the same folder. I have changed the FOLDER path and the RANGE to copy. I am getting a run-time error that reads PasteSpecial method of Range class failed on :

.PasteSpecial xlFormats

Any suggestions? Thanks.

 

[agihcam]

if you have to remove this line

.PasteSpecial xlFormats

what will happen after running the code? are the output satisfied your requirement?

 

[rrmando]

Happy new year all. Sorry for the late reply. I did remove that code (both occurrences). When I try to run it the workbook closes. I re-open it and the range I specified is highlighted in Sheet 1, but there's no data in there. I'll keep trying. Thanks again.