Copy and paste data from 10+ workbooks into one "Master" sheet

[chard]

Hi all,

I need to copy data from workbooks all contained in a folder called "Cycle Data" into a master sheet. From each of these sheets I need cells H66 and Q66 to be copied and pasted into a table that contains merged cells. I also need the name of the worksheet to be carried over with the data as a label to be pasted into one of the master sheet cells. For the first workbook, the name of the source workbook would go in the large cell in column A, H66 would go in D3:D6, and Q66 would go in D7:d10. Below is a picture of the Master sheet with the merged cells.

I would be very happy with any assistance on this problem and thank you in advance!

 

[chard]

I would like to append this thread with the code. So far it can copy the necessary formatting to the needed cell, as well as track the filename to the correct cell. The loop will only select the first file in the folder. Could someone help me fix it so that it will do every file in the folder? Also, the data of interest is not pasting correctly. It does not paste the correct value of H66 or Q66 that is specified. Thanks for any help! Here is the code:

Sub FormatCells()

Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets(1)

Dim LastRowA As Long
Dim LastRowD As Long
Dim Cycle503 As Long
Dim Cycle504 As Long

LastRowA = wkbDest.Worksheets(1).Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
LastRowD = wkbDest.Worksheets(1).Cells(wsDest.Rows.Count, "D").End(xlUp).Offset(1).Row
Const strPath As String = "C:\Users\CharlesMorton\Documents\Cycle Data\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""

Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
Dim FileName As String
FileName = Dir("C:\Users\CharlesMorton\Documents\Cycle Data\*.xls*")

wsDest.Range("A" & LastRowA).Value = FileName

Cycle503 = .Sheets(1).Range("H66").Value


wsDest.Range("D" & LastRowD).Value = Cycle503


Cycle504 = .Sheets(1).Range("Q66").Value

wsDest.Range("D" & LastRowD).Value = Cycle504

.Close savechanges:=False

wsDest.Range("K2:N11").Select
Selection.Copy
wsDest.Range("A" & LastRowA).Select
wsDest.Paste



End With
strExtension = Dir


Loop


Application.ScreenUpdating = True


End Sub

 

[chard]

Hi all, I have solved this problem. I post my code below. Hope this helps someone else with similar question!

Code:


Sub GetMidNi()

Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets(1)

Dim LastRowA As Long
Dim LastRowD As Long
Dim Cycle503 As String
Dim Cycle504 As String



Const strPath As String = "C:\Users\CharlesMorton\Documents\Cycle Data MidNi\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""

LastRowA = wkbDest.Worksheets(1).Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
LastRowD = wkbDest.Worksheets(1).Cells(wsDest.Rows.Count, "D").End(xlUp).Offset(1).Row

Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
Dim FileName As String
FileName = wkbSource.Name

wsDest.Range("A" & LastRowA).Value = FileName

If IsError(.Sheets(1).Range("H66").Value) Then
Cycle503 = "short"
Else
If .Sheets(1).Range("H66").Value = "" Then
Cycle503 = "Short"
Else
Cycle503 = .Sheets(1).Range("H66").Value
End If
End If



wsDest.Range("D" & LastRowD).Value = Cycle503


If IsError(.Sheets(1).Range("Q66").Value) Then
Cycle504 = "short"
Else
If .Sheets(1).Range("Q66").Value = "" Then
Cycle504 = "Short"
Else
Cycle504 = .Sheets(1).Range("Q66").Value
End If
End If


wsDest.Range("D" & LastRowD + 5).Value = Cycle504

.Close savechanges:=False

wsDest.Range("K1:O10").Select
Selection.Copy
wsDest.Range("A" & LastRowA + 10).Select
wsDest.Paste



End With
strExtension = Dir()


Loop


Application.ScreenUpdating = True


End Sub