• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Help with VBA Consolidate Code

Dear everyone,

I am very basic in VBA. I have just created one Code in order to consolidate data from different workbook into one single workbook. However, I feel my code is too long and I think VBA expert would have the better way to make it shorts and simple. Can you help to guide me some about this trouble?
Below is the original code which I have just created.

Thanks for your strong support. :)

Code:
Sub Consolidate()

'Try with workbook name "A"

Workbooks.Open Filename:="C:\Users\USER\Desktop\Test\VBA\New folder\A.xlsm"
Sheets("Province1").Select
Range("B1:B3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("A1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True
Windows("A.xlsm").Activate
Range("D1:D3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("D1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True
Windows("A.xlsm").Activate

Sheets("Province2").Select
Range("B1:B3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("A1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True
Windows("A.xlsm").Activate
Range("D1:D3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("D1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True


'Try another workbook name "B"


Workbooks.Open Filename:="C:\Users\USER\Desktop\Test\VBA\New folder\B.xlsm"
Sheets("Province3").Select
Range("B1:B3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("A1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True
Windows("B.xlsm").Activate
Range("D1:D3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("D1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True

Windows("B.xlsm").Activate
Sheets("Province4").Select
Range("B1:B3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("A1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True
Windows("A.xlsm").Activate
Range("D1:D3").Select
Selection.Copy
Windows("Consolidate.xlsm").Activate
Range("D1048576").Select
ActiveCell.Cells.End(xlUp).Select
ActiveCell.Cells.Offset(1, 0).Select
ActiveCell.PasteSpecial , Transpose:=True
ActiveWorkbook.Save
Application.Quit

End Sub

MOD EDIT: ADDED CODE TAGS.
 
Last edited by a moderator:
Here you go..

Code:
Sub Consoldiate()
    'Please add a reference for "Microsoft Scripting Runtime"
    'By clicking on Tools => References, scroll down to select the above library
   
    'Variable decleration
    Dim fd As Folder
    Dim fsoobj As Scripting.FileSystemObject
    Dim file As file
   
    Dim srcwb As Workbook
    Dim srcws As Worksheet
   
    Dim outputwb As Workbook
    Dim outputws As Worksheet
    Dim srclastrow As Long
    Dim outputlastrow As Long

    'Initilize the variables
    Set fsoobj = CreateObject("Scripting.FileSystemObject")
   
    'Capture the folder reference
    'In ur case it is the folder where you are selecting the files A.xlsm and B.xlsm
    Set fd = fsoobj.GetFolder("C:\Users\USER\Desktop\Test\VBA\New folder\")
   
    'This is the destination workbook
    Set outputwb = Workbooks("Consolidate.xlsm")
    Set outputws = outputwb.Worksheets(1)
   
    'Now loop thru each file avaialble in the source folder and copy the data
    For Each file In fd.Files
        Set srcwb = Workbooks.Open(file.Path, UpdateLinks:=False)
        'You can select the worksheet name by using srcwb.worksheets("worksheetname")
        'In the following code, I am using worksheet index to refer to the 1st worksheet
        Set srcws = srcwb.Worksheets(1)
       
        'Determine the last row where to copy the data in output worksheet
        outputlastrow = outputws.Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
       
        srcws.Range("B1:B3").Copy
        outputws.Range("A" & outputlastrow).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
        Application.CutCopyMode = False
    Next
End Sub
 

Attachments

  • Consolidate.xlsm
    14.5 KB · Views: 9
Here you go..

Code:
Sub Consoldiate()
    'Please add a reference for "Microsoft Scripting Runtime"
    'By clicking on Tools => References, scroll down to select the above library
  
    'Variable decleration
    Dim fd As Folder
    Dim fsoobj As Scripting.FileSystemObject
    Dim file As file
  
    Dim srcwb As Workbook
    Dim srcws As Worksheet
  
    Dim outputwb As Workbook
    Dim outputws As Worksheet
    Dim srclastrow As Long
    Dim outputlastrow As Long

    'Initilize the variables
    Set fsoobj = CreateObject("Scripting.FileSystemObject")
  
    'Capture the folder reference
    'In ur case it is the folder where you are selecting the files A.xlsm and B.xlsm
    Set fd = fsoobj.GetFolder("C:\Users\USER\Desktop\Test\VBA\New folder\")
  
    'This is the destination workbook
    Set outputwb = Workbooks("Consolidate.xlsm")
    Set outputws = outputwb.Worksheets(1)
  
    'Now loop thru each file avaialble in the source folder and copy the data
    For Each file In fd.Files
        Set srcwb = Workbooks.Open(file.Path, UpdateLinks:=False)
        'You can select the worksheet name by using srcwb.worksheets("worksheetname")
        'In the following code, I am using worksheet index to refer to the 1st worksheet
        Set srcws = srcwb.Worksheets(1)
      
        'Determine the last row where to copy the data in output worksheet
        outputlastrow = outputws.Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
      
        srcws.Range("B1:B3").Copy
        outputws.Range("A" & outputlastrow).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
        Application.CutCopyMode = False
    Next
End Sub
Thanks Ramesh for the code. I'll test with it.
 
Back
Top