Copy Cells from 2 or more workbooks to a new workbook - vba

Question

I am trying to write some code which copies cells C24, C25 and D24, D25 from all the .xls files from location "C:\MyPath\" and I'm new to using VBA but I was looking for some solution online and was able to make up some code which combines all excel files in a folder and copies it to single workbook with each workbook going into each sheet.
Th code I worked on is
Option Explicit
Sub CopyWorksheets()
Const sPath = "C:\MyPath\"
Dim sFile As String
Dim wbkSource As Workbook
Dim wSource As Worksheet
Dim wbkTarget As Workbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Set wbkTarget = ActiveWorkbook
sFile = Dir(sPath & "*.xls*")
Do While Not sFile = ""
Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
For Each wSource In wbkSource.Worksheets
With wbkTarget
wSource.Copy After:=.Sheets(.Sheets.Count)
End With
Next
wbkSource.Close SaveChanges:=False
sFile = Dir
Loop
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
May I know the changes or additions to the above code to get my solution?

Answer 1

I copied your code to a new workbook. I renamed worksheet Sheet1 as C24D25 and created a header row:
A B C D E F
1 Workbook Worksheet C24 D24 C25 D25
At the top of your routine I added the extra variables and constants I required:
Const colTgtWbk As Long = 1
Const colTgtWsht As Long = 2
Const colTgtC24 As Long = 3
Const colTgtC25 As Long = 5
Dim wshtTarget As Worksheet
Dim rowTgtCrnt As Long
Set wshtTarget = ActiveWorkbook.Worksheets("C24D25")
rowTgtCrnt = 2
Replace “C24D25” with your name for the worksheet into which values are collected.
I amended the definition of sPath to a folder on my laptop containing several workbooks.
Near the top of your code I commented out:
'On Error GoTo ErrHandler
and near the end I commented out:
'ExitHandler:
'Exit Sub
'ErrHandler:
'MsgBox Err.Description, vbExclamation
'Resume ExitHandler
I never include my own error handler during development and I never include one in a production macro unless I have discovered a need during development. An error handler routine is not the best method for handling errors you expect and can test for. They should be reserved for errors you cannot test for such as attempting to open a file for which you may not have read permission.
Around your main block:
Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
to
wbkSource.Close SaveChanges:=False
I added an If:
If sFile <> wbkTarget.Name Then
End If
This avoids attempting to reopen the workbook in which you are collecting data.
I deleted:
With wbkTarget
wSource.Copy After:=.Sheets(.Sheets.Count)
End With
and replaced this code with:
With wshtTarget
.Cells(rowTgtCrnt, colTgtWbk).Value = wbkSource.Name
.Cells(rowTgtCrnt, colTgtWsht).Value = wSource.Name
wSource.Range("C24:D24").Copy Destination:=.Cells(rowTgtCrnt, colTgtC24)
wSource.Range("C25:D25").Copy Destination:=.Cells(rowTgtCrnt, colTgtC25)
rowTgtCrnt = rowTgtCrnt + 1
End With
This is the code that builds the rows in worksheet C24D25.
At the bottom I added:
wshtTarget.Columns.AutoFit
This expands the columns to the width of the data found.
The result of the changes above is:
Option Explicit
Sub CopyWorksheets()
Const colTgtWbk As Long = 1
Const colTgtWsht As Long = 2
Const colTgtC24 As Long = 3
Const colTgtC25 As Long = 5
Dim wshtTarget As Worksheet
Dim rowTgtCrnt As Long
Set wshtTarget = ActiveWorkbook.Worksheets("C24D25")
rowTgtCrnt = 2
Const sPath = "C:\DataArea\SOTest\Excel\"
Dim sFile As String
Dim wbkSource As Workbook
Dim wSource As Worksheet
Dim wbkTarget As Workbook
Application.ScreenUpdating = False
Set wbkTarget = ActiveWorkbook
sFile = Dir(sPath & "*.xls*")
Do While sFile <> ""
If sFile <> wbkTarget.Name Then
Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
For Each wSource In wbkSource.Worksheets
With wshtTarget
.Cells(rowTgtCrnt, colTgtWbk).Value = wbkSource.Name
.Cells(rowTgtCrnt, colTgtWsht).Value = wSource.Name
wSource.Range("C24:D24").Copy Destination:=.Cells(rowTgtCrnt, colTgtC24)
wSource.Range("C25:D25").Copy Destination:=.Cells(rowTgtCrnt, colTgtC25)
rowTgtCrnt = rowTgtCrnt + 1
End With
Next
wbkSource.Close SaveChanges:=False
End If
sFile = Dir
Loop
wshtTarget.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
I hope the purposes of the changes I have made are obvious, Ask questions if necessary.