Copying data from multiple sheets with VBA

[pillaisg]

Hi Good day,
I have multiple excel workbooks which I have kept in "C:\Combine" folder. I need to take the data from each workbook and populate it into an excel workbook having a sheet "merged".
I have just tried to do with a code .. which is below. Could anyone please help me..... I am a beginner.

Option Explicit
Sub Com()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim NewSht As Worksheet
Dim ActBook As Workbook
Dim a As Long
Dim i As Long
Dim ActSht As Worksheet
Dim MyFolder As String
Dim StrFilename As String
Dim lngcount As Long

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

Set ActBook = ActiveWorkbook
Set ActSht = ActBook.Worksheets("Merged")
MyFolder = "C:\Combine"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Set NewSht = wbDst.Worksheets(1)
StrFilename = Dir(MyFolder & "\*.xls*", vbNormal)

a = 2

NewSht.Range("A1") = "Structure Code"
NewSht.Range("B1") = "Level Area Code"
NewSht.Range("C1") = "Drawing No."
NewSht.Range("D1") = " Rev. No."
NewSht.Range("E1") = "Equipment/ Cable Tray Tag No."
NewSht.Range("F1") = "Qty "
NewSht.Range("G1") = "Tag Description"
NewSht.Range("H1") = "Eng Trl No"
NewSht.Range("I1") = "Eng Trl Date"
NewSht.Range("J1") = "Pmt Trl No"
NewSht.Range("K1") = "Pmt Trl Date"
NewSht.Range("L1") = "Tag Type Code"
NewSht.Range("M1") = "ERECTION LOCATION"

If Len(StrFilename) = 0 Then Exit Sub

Do Until StrFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyFolder & "\" & StrFilename, UpdateLinks:=0, ReadOnly:=False)
Set wsSrc = wbSrc.Worksheets(1)

For i = 2 To 46
NewSht.Cells(a, "A") = wsSrc.Cells(i, "A")
NewSht.Cells(a, "B") = wsSrc.Cells(i, "B")
NewSht.Cells(a, "C") = wsSrc.Cells(i, "C")
NewSht.Cells(a, "D") = wsSrc.Cells(i, "D")
NewSht.Cells(a, "E") = wsSrc.Cells(i, "E")
NewSht.Cells(a, "F") = wsSrc.Cells(i, "F")
NewSht.Cells(a, "G") = wsSrc.Cells(i, "G")
NewSht.Cells(a, "H") = wsSrc.Cells(i, "H")
NewSht.Cells(a, "I") = wsSrc.Cells(i, "I")
NewSht.Cells(a, "J") = wsSrc.Cells(i, "J")
NewSht.Cells(a, "K") = wsSrc.Cells(i, "K")
NewSht.Cells(a, "L") = wsSrc.Cells(i, "L")
NewSht.Cells(a, "M") = wsSrc.Cells(i, "M")

a = a + 1
Next i

wbSrc.Save
wbSrc.Close
StrFilename = Dir()
Loop


End Sub

 

[Herakles]

Can we assume that it is ALL workbooks in the C:\Combine folder and ALL worksheets in the each of these workbooks.

Also are the columns in the same order throughout?

 

[pillaisg]

Yes... All the workbooks will be kept in the C:\Combine folder and all worksheets shall have only one sheet and the columns are throughout.

 

[Skyybot]

Hi Good day,
I have multiple excel workbooks which I have kept in "C:\Combine" folder. I need to take the data from each workbook and populate it into an excel workbook having a sheet "merged".
I have just tried to do with a code .. which is below. Could anyone please help me..... I am a beginner.

Option Explicit
Sub Com()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim NewSht As Worksheet
Dim ActBook As Workbook
Dim a As Long
Dim i As Long
Dim ActSht As Worksheet
Dim MyFolder As String
Dim StrFilename As String
Dim lngcount As Long

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

Set ActBook = ActiveWorkbook
Set ActSht = ActBook.Worksheets("Merged")
MyFolder = "C:\Combine"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Set NewSht = wbDst.Worksheets(1)
StrFilename = Dir(MyFolder & "\*.xls*", vbNormal)

a = 2

NewSht.Range("A1") = "Structure Code"
NewSht.Range("B1") = "Level Area Code"
NewSht.Range("C1") = "Drawing No."
NewSht.Range("D1") = " Rev. No."
NewSht.Range("E1") = "Equipment/ Cable Tray Tag No."
NewSht.Range("F1") = "Qty "
NewSht.Range("G1") = "Tag Description"
NewSht.Range("H1") = "Eng Trl No"
NewSht.Range("I1") = "Eng Trl Date"
NewSht.Range("J1") = "Pmt Trl No"
NewSht.Range("K1") = "Pmt Trl Date"
NewSht.Range("L1") = "Tag Type Code"
NewSht.Range("M1") = "ERECTION LOCATION"

If Len(StrFilename) = 0 Then Exit Sub

Do Until StrFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyFolder & "\" & StrFilename, UpdateLinks:=0, ReadOnly:=False)
Set wsSrc = wbSrc.Worksheets(1)

For i = 2 To 46
NewSht.Cells(a, "A") = wsSrc.Cells(i, "A")
NewSht.Cells(a, "B") = wsSrc.Cells(i, "B")
NewSht.Cells(a, "C") = wsSrc.Cells(i, "C")
NewSht.Cells(a, "D") = wsSrc.Cells(i, "D")
NewSht.Cells(a, "E") = wsSrc.Cells(i, "E")
NewSht.Cells(a, "F") = wsSrc.Cells(i, "F")
NewSht.Cells(a, "G") = wsSrc.Cells(i, "G")
NewSht.Cells(a, "H") = wsSrc.Cells(i, "H")
NewSht.Cells(a, "I") = wsSrc.Cells(i, "I")
NewSht.Cells(a, "J") = wsSrc.Cells(i, "J")
NewSht.Cells(a, "K") = wsSrc.Cells(i, "K")
NewSht.Cells(a, "L") = wsSrc.Cells(i, "L")
NewSht.Cells(a, "M") = wsSrc.Cells(i, "M")

a = a + 1
Next i

wbSrc.Save
wbSrc.Close
StrFilename = Dir()
Loop


End Sub

At what line does the code fail?

 

[pillaisg]

At what line does the code fail?

 

[pillaisg]

Hi,
The data is not being copied properly. I have kept the files in the link.
THe file "Merged" is the one with the VBA code and the other files which are to be combined is 1.xlsx, 2.xlsx, & 3.xlsx parked in the link


link

 

[Skyybot]

Hi,
The data is not being copied properly. I have kept the files in the link.
THe file "Merged" is the one with the VBA code and the other files which are to be combined is 1.xlsx, 2.xlsx, & 3.xlsx parked in the link


link

What I meant to ask was: When you Step through the code line by line, at which line does it fail? This will help me pinpoint the issue without having to clone your file tree on my machine.

 

[pillaisg]

ough the code line by line, at which line does it fail? This will help me pinpoint the issue without having to clone your file tree on my machine.

 

[pillaisg]

The error which I noticed is that the code is not running through all the Workbook in the folder. It is only taking the information from the 1st workbook.

 

[dmt32]

Hi,
only lightly tested but see if this update to your code will do what you want

Sub MergeSheets()
    
    Dim strFileName     As String, strNewFileName   As String
    Dim wbSource        As Workbook, wbMerge        As Workbook
    Dim wsMerge         As Worksheet
    Dim iCount             As Long
    
    ' change to suit
    Const MyFolder  As String = "C:\Combine"
    
    'if sheets you are copying are protected with password
    'enter password between the quotes otherwise, leave empty.
    Const wsPassword As String = ""
    
    On Error GoTo myerror
    
    'check path exists
    If Dir(MyFolder, vbDirectory) = vbNullString Then Err.Raise 76
    
    strFileName = Dir(MyFolder & "\*.xlsx*", vbNormal)
    
    Application.ScreenUpdating = False
    
    Do While strFileName <> ""
        
        Set wbSource = Workbooks.Open(Filename:=MyFolder & "\" & strFileName, UpdateLinks:=0, ReadOnly:=True)
        
        If iCount > 0 Then
            'copy merge data
            wbSource.Worksheets(1).UsedRange.Offset(1).Copy wsMerge.Cells(wsMerge.Rows.Count, "A").End(xlUp).Offset(1, 0)
            
            wbSource.Close False
            Set wbSource = Nothing
            
        Else
            'create merge sheet
            Set wsMerge = wbSource.Worksheets(1)
            
            With wsMerge
                .Unprotect wsPassword
                .Rows(1).EntireRow.Delete
                .Name = "Merged"
            End With
            
            ActiveWindow.View = xlNormalView
            
        End If
        
        iCount = iCount + 1
        strFileName = Dir
    Loop
    
    'save merge workbook
    strNewFileName = "Electrical Cable Schedule Combined_" & Format(Now(), "dd-mm-yyyy_hh.nn.ss AM/PM")
    wsMerge.Parent.SaveAs ThisWorkbook.Path & "\" & strNewFileName & ".xlsx", FileFormat:=51, CreateBackup:=False
    
myerror:
    If Not wbSource Is Nothing Then wbSource.Close False
    Application.ScreenUpdating = True
    
    If Err <> 0 Then
    'report errors
        MsgBox (Error(Err)), 48, "Error"
    Else
    'inform user
        MsgBox iCount & " - Sheets Merged", 64, "Merge Complete"
    End If
    
End Sub

Dave