I need a code that will merge 200 Excel files into one single document. The headers and information in the files are the same and are located on pages named "ms". There is a blank "mb" page in the main workbook to which I want to copy data from the workbooks in the "All" folder. An error occurs at the:
`ws.Cells.Copy line`
My code:
`Sub CombineData()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim myPath As String
Dim myFile As String
myPath = "C:\Users\d.pavlov\Documents\All"
Set ws = ActiveWorkbook.Sheets("ms")
e data
Set wsMaster = Workbooks("Master Workbook.xlsx").Sheets("mb")
lastRow = wsMaster.Cells(Rows.Count, 1).End(xlUp).Row
myFile = Dir(myPath & "\*.xlsx")
Do While myFile <> ""
Set wb = Workbooks.Open(Filename:=myPath & "\" & myFile)
ws.Cells.Copy
wsMaster.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
wb.Close False
lastRow = wsMaster.Cells(Rows.Count, 1).End(xlUp).Row
myFile = Dir
Loop
End Sub`
I found an interesting solution, the code works and helped me:
'Option Explicit
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean, IsPasteSheetName As Boolean
On Error Resume Next
'Select a range of samples from books
Set iBeginRange = Application.InputBox("Select the data collection range." & vbCrLf & _
"1. If you select only one cell, data will be collected from all sheets starting with that cell." & _
vbCrLf & "2. If you select multiple cells, data will be collected only from the specified range of all sheets.",Type:=8)
'to specify a range without a dialog box:
'Set iBeginRange = Range("A1:A10") 'the range is specified as desired
'If the range is not selected, we complete the procedure
If iBeginRange Is Nothing Then
Exit Sub
End If
'Specify the sheet name
'It is permissible to specify the ? and * symbols in the sheet name.
'If you specify only *, the data will be collected from all sheets
sSheetName = InputBox("Enter the name of the sheet from which to collect data (if not specified, then data is collected from all sheets)", "Parameter")
'If the sheet name is not specified, data will be collected from all sheets
If sSheetName = "" Then
sSheetName = "*"
End If
'whether to add sheet name to beginning of table
IsPasteSheetName = (MsgBox("Insert sheet name as first column?", vbQuestion + vbYesNo) = vbYes)
On Error GoTo 0
'Query - insert all data into the resulting sheet
'or just cell values (without formulas and formats)
bPasteValues = (MsgBox("Insert values only?", vbQuestion + vbYesNo= vbYes)
'Request to collect data from books (if No, then collection is from the active book)
If MsgBox("Collect data from multiple books?", vbInformation + vbYesNo) = vbYes Then
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Select files", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 1
Else
avFiles = Array(ThisWorkbook.FullName)
End If
If IsPasteSheetName Then
lCol = lCol + 1
End If
'disable screen refresh, automatic formula recalculation and event tracking
'for code execution speed and to avoid errors if there are other codes in the books With Application
lCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
End With
'create a new sheet in the book for collection
Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
'if you need to collect data on a new workbook sheet with the code
'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'loop through books
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then
Set wbAct = Workbooks.Open(Filename:=avFiles(li))
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct.Name
'cycle by sheets
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
'If the sheet name matches the name of the sheet in which we are ‘collecting data
'and the collection is only from the active book, then we move on to the next sheet If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1 'collect data starting from the specified cell and until the end of the data
lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = .Cells.SpecialCells(xlLastCell).Column
sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
Case Else 'collect data from a fixed range
sCopyAddress = iBeginRange.Address
End Select
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
'we define for copying a range of only filled data on the sheet
Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress))
'insert the name of the book from which the data was collected
If lCol > 0 Then
If bPolyBooks Then
wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb
End If
If IsPasteSheetName Then
wsDataSheet.Cells(lLastRowMyBook, lCol).Resize(rCopy.Rows.Count).Value = .Name
End If
End If
'if we insert only values
If bPasteValues Then
rCopy.Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats
Else 'if we insert all the cell data (formulas, formats, etc.) rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
End If
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then
wbAct.Close False
End If
Next li
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lCalc
End With
End Sub'
Option Explicit
Sub CombineData()
Const FOLDER = "C:\Users\d.pavlov\Documents\All"
Dim wb As Workbook, wsMaster As Worksheet, rngTo As Range
Dim myFile As String, r As Long, c As Long, n As Long
Dim t0 As Single: t0 = Timer
Set wsMaster = Workbooks("Master Workbook.xlsx").Sheets("mb")
With wsMaster
Set rngTo = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
myFile = Dir(FOLDER & "\*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Set wb = Workbooks.Open(Filename:=FOLDER & "\" & myFile)
With wb.Sheets("ms")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
rngTo.Resize(r, c).Value = .Range("A1").Resize(r, c).Value
Set rngTo = rngTo.Offset(r)
n = n + 1
End With
wb.Close False
myFile = Dir
Loop
Application.ScreenUpdating = True
MsgBox n & " files imported from " & FOLDER, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub