Merging multiple workbook data into one sheet

[sk0926]

HI,

I am trying to copy paste data from multiple (over 300 workbooks) workbooks to one sheet so that I can analyze the data.
Below is what I found from the forum (with small modification like the range), which worked great except I need one modification.
The origin data sheets have data in range a31:l42 all the time, but cell B10 has date information. Ideally, I would like to have B10 date copied into column A 12 times so I would have the date next to my data (a31:l42, 12 rows) starting in column B.

Can anybody help me figuring this out?


Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Const strPath As String = "C:\Users\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
LastRow = .Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Sheet1").Range("a31:l42").Copy wkbDest.Sheets("Master").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[denzo36]

Why don't you use Power Query? If that data is in the same format in all workbooks then Power Query will achieve without much hassle

 

[DanteAmor]

Hi and welcome to MrExcel

I made several changes to your code, try the following:

Sub CopyRange()
  Application.ScreenUpdating = False
  Dim wshDest As Worksheet, wkbSource As Workbook
  Dim lr As Long, strExtension As Variant
  
  Set wshDest = ThisWorkbook.Sheets("Master")
  Const strPath As String = "C:\Users\"
  ChDir strPath
  strExtension = Dir("*.xls*")
  
  Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)
    With wkbSource.Sheets("Sheet1")
      lr = wshDest.Range("B" & Rows.Count).End(3).Row + 1
      .Range("a31:l42").Copy wshDest.Range("B" & lr)
      wshDest.Range("A" & lr).Resize(12).Value = .Range("B10").Value
      wkbSource.Close savechanges:=False
    End With
    strExtension = Dir
  Loop
  
  Application.ScreenUpdating = True
End Sub

 

[sk0926]

DanteAmor, the code works perfect.

denzo36, I tried the Power Query for the first time and query does what I wanted as well.

Thank you both!

 

[DanteAmor]

Glad we could help & thanks for the feedback