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

 

[pillaisg]

Perfect.... Thanks a lot for the code...

 

[dmt32]

Perfect.... Thanks a lot for the code...

welcome - appreciate your feedback

Dave

 

[pillaisg]

As a part of understanding the code which was shared, I had retyped the code line by line.. but the following line is showing an error which I am not able to understand eventhough it is same as your code. Appreciate if you could help me understand the error.

wsMerge.Parent.SaveAs ThisWorkbook.Path & "\" & strNewFileName & ".xlsx", FileFormat:=51, CreateBackup:=False

But when I run the code which has been shared, it runs perfectly...

Sub MergeSheets()
Dim strFileName As String, strNewFileName As String
Dim wbSource As Workbook, wbMerge As Workbook
Dim wsMerge As Worksheet
Dim iCount As Long


Const MyFolder As String = "C:\Combine"

If Dir(MyFolder, vbDirectory) = vbNullString Then Err.Raise 76

strFileName = Dir(MyFolder & "\*.xls*", vbNormal)

Application.ScreenUpdating = False

Do While strFileName <> ""

Set wbSource = Workbooks.Open(Filename:=MyFolder & "\" & strFileName, UpdateLinks:=0, ReadOnly:=True)

If iCount > 0 Then

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

Set wsMerge = wbSource.Worksheets(1)

With wsMerge

.Rows(1).EntireRow.Delete

.Name = "Merged"

End With

ActiveWindow.View = xlNormalView
End If

iCount = iCount + 1

strFileName = Dir

Loop

strNewFileName = "Combined" & Format(Now(), "dd-mm-yyyy_hh.nn.ss AM/PM")

wsMerge.Parent.SaveAs ThisWorkbook.Path & "\" & strNewFileName & ".xlsx", FileFormat:=51, CreateBackup:=False

If Not wbSource Is Nothing Then wbSource.Close False

Application.sreenupadating = True

If Err <> 0 Then

MsgBox (Error(Err)), 48, "Error"

Else

MsgBox iCount & "-Sheets Merged", 64, "Merge Complete"

End If

End Sub

 

[dmt32]

Hi,
I ran your re-type & seemed to work ok to a point but not sure why need to do this if posted code does what you want? - you have though, missed the error handling lines of code

On Error GoTo myerror
  
    'code
  
myerror:
'error handling

also, you have a typo which caused an error

Application.sCreenupadating = True

Please also use code tags when posting code - In the menu bar press VBA & place your code between the tags

Dave

 

[pillaisg]

Thanks and appreciate your help and guidance.

 

[dmt32]

Thanks and appreciate your help and guidance.

welcome - please remember to mark code used as Solution

Dave

 

[smozgur]

Perfect.... Thanks a lot for the code...

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.