Pulling data from a workbook with a different sheet name - excel

I have a code that is able to pull data from a specified folder (specifically excel files with same sheet name) and combine it. I'm trying to modify it so I can pull data from a different excel file with multiple different sheet names (This file has multiple sheets I want to pull data from). I will paste the code below. The name of the new excel file I'm trying to pull data from is title "Match Attainment and Lot Reports" and there are 6 sheets I'm trying to get data from namely "Curtis 1703", "Big Meadows 2101", "Molino 1102", "Oro Fino 1102", "Pueblo 2103", and "Middletown 1101".
Option Explicit
Public Sub CombineManyWorkbooksIntoOneWorksheet()
Dim strDirContainingFiles As String, strFile As String, _
strFilePath As String
Dim wbkDst As Workbook, wbkSrc As Workbook
Dim wksDst As Worksheet, wksSrc As Worksheet
Dim lngIdx As Long, lngSrcLastRow As Long, _
lngSrcLastCol As Long, lngDstLastRow As Long, _
lngDstLastCol As Long, lngDstFirstFileRow As Long
Dim rngSrc As Range, rngDst As Range, rngFile As Range
Dim colFileNames As Collection
Set colFileNames = New Collection
'Dim filename As String
'filename = ThisWorkbook.Path & Application.PathSeparator & "Match Attainment and Lot Reports.xlsx"
'Dim wk As Workbook
'Set wk = Workbooks.Open(filename)
'Set references up-front
strDirContainingFiles = "P:\Inspections - ISM\Infrastructure Inspection\Distribution\Completed\CSV Exports" '<~ your folder
Set wbkDst = Workbooks.Add '<~ Dst is short for destination
Set wksDst = wbkDst.ActiveSheet
'Store all of the file names in a collection
strFile = Dir(strDirContainingFiles & "\*.xlsx")
Do While Len(strFile) > 0
colFileNames.Add Item:=strFile
strFile = Dir
Loop
''CHECKPOINT: make sure colFileNames has the file names
'Dim varDebug As Variant
' For Each varDebug In colFileNames
' Debug.Print varDebug
' Next varDebug
'Now we can start looping through the "source" files
'and copy their data to our destination sheet
For lngIdx = 1 To colFileNames.Count
'Assign the file path
strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
'Open the workbook and store a reference to the data sheet
Set wbkSrc = Workbooks.Open(strFilePath)
Set wksSrc = wbkSrc.Worksheets("Distribution Review of Inspecti") '<~ change based on your Sheet name
'Identify the last row and last column, then
'use that info to identify the full data range
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
lngSrcLastCol = LastOccupiedColNum(wksSrc)
With wksSrc
Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, _
lngSrcLastCol))
End With
''CHECKPOINT: make sure we have the full source data range
'wksSrc.Range("A1").Select
'rngSrc.Select
'If this is the first (1st) loop, we want to keep
'the header row from the source data, but if not then
'we want to remove it
If lngIdx <> 1 Then
Set rngSrc = rngSrc.Offset(1, 0).Resize(rngSrc.Rows.Count - 1)
End If
''CHECKPOINT: make sure that we remove the header row
''from the source range on every loop that is not
''the first one
'wksSrc.Range("A1").Select
'rngSrc.Select
'Copy the source data to the destination sheet, aiming
'for cell A1 on the first loop then one past the
'last-occupied row in column A on each following loop
If lngIdx = 1 Then
lngDstLastRow = 1
Set rngDst = wksDst.Cells(1, 1)
Else
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste
'Almost done! We want to add the source file info
'for each of the data blocks to our destination
'On the first loop, we need to add a "Source Filename" column
If lngIdx = 1 Then
lngDstLastCol = LastOccupiedColNum(wksDst)
wksDst.Cells(1, lngDstLastCol + 1) = "Source Filename"
End If
'Identify the range that we need to write the source file
'info to, then write the info
With wksDst
'The first row we need to write the file info to
'is the same row where we did our initial paste to
'the destination file
lngDstFirstFileRow = lngDstLastRow + 1
'Then, we need to find the NEW last row on the destination
'sheet, which will be further down (since we pasted more
'data in)
lngDstLastRow = LastOccupiedRowNum(wksDst)
lngDstLastCol = LastOccupiedColNum(wksDst)
'With the info from above, we can create the range
Set rngFile = .Range(.Cells(lngDstFirstFileRow, lngDstLastCol), _
.Cells(lngDstLastRow, lngDstLastCol))
''CHECKPOINT: make sure we have correctly identified
''the range where our file names will go
'wksDst.Range("A1").Select
'rngFile.Select
'Now that we have that range identified,
'we write the file name
rngFile.Value = wbkSrc.Name
End With
'Close the source workbook and repeat
wbkSrc.Close SaveChanges:=False
'wk.Close SaveChanges:=False
Next lngIdx
'Let the user know that the combination is done!
MsgBox "Data combined!"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function

Related

VBA File Collections need to only add specific files

I have never worked with file collections before, but I was able to find the code below (https://danwagner.co/how-to-combine-multiple-excel-workbooks-into-one-worksheet-with-vba/). I have a file location that could have over 120+ files. I needed the sub to browse to that file location, loop through the files and copy/append data to a new workbook. And that parts works perfectly. My issue is that I don't need it to add all the files to the collection. Each filename begins with a 4 digit year, i.e. 2019_M05 (meaning May of 2019). I only need it to look at the past 7 years files. Ive tried using an if on the strFile name, but it locks my excel every time. Unfortunately, they need all the data in one file and it could be over 500k lines. Any suggestions would be appreciated.
Public Sub Create820Accumulatorfile()
Dim wb1 As Workbook
Dim strDirContainingFiles As String, strFile As String, _
strFilePath As String, stryears As String
Dim wbkDst As Workbook, wbkSrc As Workbook
Dim wksDst As Worksheet, wksSrc As Worksheet
Dim lngIdx As Long, lngSrcLastRow As Long, _
lngSrcLastCol As Long, lngDstLastRow As Long, _
lngDstLastCol As Long, lngDstFirstFileRow As Long
Dim rngSrc As Range, rngDst As Range, rngFile As Range
Dim colFileNames As Collection
Set colFileNames = New Collection
Dim StartingTime As Single
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate = xlCalculationManual
Set wb1 = ThisWorkbook
StartingTime = Timer
'Set references up-front
strDirContainingFiles = wb1.Sheets("Start Here").Range("B11").Value '<~ your folder
stryears = wb1.Sheets("Start Here").Range("B12").Value '<~ years for files to include
Set wbkDst = Workbooks.Add '<~ Dst is short for destination
Set wksDst = wbkDst.ActiveSheet
'Store all of the file names in a collection
strFile = Dir(strDirContainingFiles & "\*.xlsx")
Do While Len(strFile) > 0
colFileNames.Add Item:=strFile
strFile = Dir
Loop
''CHECKPOINT: make sure colFileNames has the file names
'Dim varDebug As Variant
'For Each varDebug In colFileNames
' Debug.Print varDebug
'Next varDebug
'Now we can start looping through the "source" files
'and copy their data to our destination sheet
For lngIdx = 1 To colFileNames.Count
'Assign the file path
strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
'Open the workbook and store a reference to the data sheet
Set wbkSrc = Workbooks.Open(strFilePath)
Set wksSrc = wbkSrc.Worksheets("Excel_Destination") '<~ change based on your Sheet name
'Identify the last row and last column, then
'use that info to identify the full data range
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
lngSrcLastCol = LastOccupiedColNum(wksSrc)
With wksSrc
Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, _
lngSrcLastCol))
End With
''CHECKPOINT: make sure we have the full source data range
'wksSrc.Range("A1").Select
'rngSrc.Select
'If this is the first (1st) loop, we want to keep
'the header row from the source data, but if not then
'we want to remove it
If lngIdx <> 1 Then
Set rngSrc = rngSrc.Offset(1, 0).Resize(rngSrc.Rows.Count - 1)
End If
''CHECKPOINT: make sure that we remove the header row
''from the source range on every loop that is not
''the first one
'wksSrc.Range("A1").Select
'rngSrc.Select
'Copy the source data to the destination sheet, aiming
'for cell A1 on the first loop then one past the
'last-occupied row in column A on each following loop
If lngIdx = 1 Then
lngDstLastRow = 1
Set rngDst = wksDst.Cells(1, 1)
Else
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste
'Almost done! We want to add the source file info
'for each of the data blocks to our destination
'On the first loop, we need to add a "Source Filename" column
If lngIdx = 1 Then
lngDstLastCol = LastOccupiedColNum(wksDst)
wksDst.Cells(1, lngDstLastCol + 1) = "Source Filename"
End If
'Identify the range that we need to write the source file
'info to, then write the info
With wksDst
'The first row we need to write the file info to
'is the same row where we did our initial paste to
'the destination file
lngDstFirstFileRow = lngDstLastRow + 1
'Then, we need to find the NEW last row on the destination
'sheet, which will be further down (since we pasted more
'data in)
lngDstLastRow = LastOccupiedRowNum(wksDst)
lngDstLastCol = LastOccupiedColNum(wksDst)
'With the info from above, we can create the range
Set rngFile = .Range(.Cells(lngDstFirstFileRow, lngDstLastCol), _
.Cells(lngDstLastRow, lngDstLastCol))
''CHECKPOINT: make sure we have correctly identified
''the range where our file names will go
'wksDst.Range("A1").Select
'rngFile.Select
'Now that we have that range identified,
'we write the file name
rngFile.Value = wbkSrc.Name
End With
'Close the source workbook and repeat
wbkSrc.Close SaveChanges:=False
Next lngIdx
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculate = xlCalculationAutomatic
'Let the user know that the combination is done!
MsgBox "Data combined! " & Format((Timer - StartingTime) / 86400, "hh:mm:ss")
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
I know I need to add it in this section of the code. I tried creating a variable to hold the year of the file and it tests against a user inputted starting date, but the loop is going through 100+ files and it crashes my excel. I don't get any errors other than the crash.
'Store all of the file names in a collection
Dim fileyear as long
strFile = Dir(strDirContainingFiles & "\*.xlsx")
Do While Len(strFile) > 0
fileyear = left(strFile, 2)
if fileyear >= wb1.Sheets("Start Here").Range("B12").Value then
colFileNames.Add Item:=strFile
strFile = Dir
end if
Loop
Writing Consecutive Numbers to a Dictionary
The following is something like the idea presented by Daniel Dušek in the comments.
Here is a great dictionary resource. Here is a Youtube playlist from the same author.
Dim YearsCount As Long
YearsCount = wb1.Sheets("Start Here").Range("B12").Value
Dim LastYear As Long: LastYear = Year(Date) ' current year...
' ... or read from a cell like the years count
Dim dictYears As Object
Set dictYears = CreateObject("Scripting.Dictionary")
Dim y As Long
For y = 0 To YearsCount - 1
dictYears(CStr(LastYear - y)) = Empty
Next y
strFile = Dir(strDirContainingFiles & "\*.xlsx")
Do While Len(strFile) > 0
If dict.Exists(Left(strFile, 4)) Then
colFileNames.Add Item:=strFile
strFile = Dir
End If
Loop

Looping Through 2 Columns & Copying 2nd Column's Data Under the First

I am trying to create a list with 2 columns by placing the values from the 2nd column under the first on a new tab. In my screenshot I have column A "Data 1" and column B "Data 2". Each value under Data 1 has a corresponding value under Data 2. I am trying to make it look like the Second Tab column where the value under Data 1 is copied over first then Data 2 is Copied underneath. There are blanks in between values so im trying to figure out a way to capture all the data excluding the blanks so its 1 organized list. I have tried the following so far but i cant figure it out:
Sub MoveData()
Dim wb As Workbook: Set wb = ThisWorkbook
For i = 1 To 15
wb.Sheets("Sheet1").Range("A2:A" & i).Copy Destination:=wb.Sheets("Sheet2").Range("A1")
wb.Sheets("Sheet1").Range("A2:A" & i).Offset(0, 1).Copy _
Destination:=wb.Sheets("Sheet2").Range("A2" & lastrow).Offset(1, 0)
wb.Sheets("Sheet1").Range("A2:A" & i).Offset(0, 1).Copy _
Destination:=wb.Sheets("Sheet2").Range("A2:A" & i).Offset(1, 0)
Next i
End Sub
With the help of the following function you will find the last non empty row in column 1
Function FindLastRow(rg As Range) As Long
On Error GoTo EH
FindLastRow = rg.Find("*", , Lookat:=xlPart, LookIn:=xlFormulas _
, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Exit Function
EH:
FindLastRow = rg.Cells(1, 1).Row
End Function
Then you can copy the data into worksheet 2 with the following code
Sub pasteData()
Dim wks1 As Worksheet
Set wks1 = Worksheets("Sheet1")
Dim lastRow As Long
lastRow = FindLastRow(wks1.Columns(1)) ' last non empty row in column 1
Dim rg As Range
Set rg = wks1.Range("A1:B" & lastRow) 'range with the data in question
Dim vdat As Variant
vdat = rg.Value ' copy the data into an arry
' dim array which is big enough for the result
Dim rDat As Variant
ReDim rDat(0 To 2 * lastRow)
' copy the data from the 2-dim array into 1-dim array
Dim i As Long, j As Long
For i = LBound(vdat) To UBound(vdat)
' copy only data where the first column contains data
If Len(vdat(i, 1)) > 0 Then
rDat(j) = vdat(i, 1)
rDat(j + 1) = vdat(i, 2)
j = j + 2
End If
Next i
Dim wks2 As Worksheet
Set wks2 = Worksheets("Sheet2")
' prepare the second range (bigger than needed but does not harm)
Set rg = wks2.Range("A1:A" & 2 * lastRow)
' copy the data into the second sheet
rg = WorksheetFunction.Transpose(rDat)
End Sub

How to fix 'Run-time error '1004' PasteSpecial

I have a file (called original) that has partially information for each row. Each row has a file name column (from where information is to be captured from).
For each row I'd like to open up the file in the file name column, and grab information from certain rows.
In the file it is only one column, with rows "Supplier Number : _____", the location of this row is variable, so I'd like to iterate through each row in the file to copy this cell value and paste it into the original file in the corresponding row.
This is what I have so far:
Const FOLDER_PATH = "C:\Users\[user]\Downloads\"
Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim source As String
Dim target As String
Dim update As String
Dim rowT As Integer
rowT = 2
rowTT = 1
Dim rowRange As Range
Dim colRange As Range
Dim rowRangeT As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowT As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A2:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
source = FOLDER_PATH & wks.Cells(i, 18).Value 'the name of the file we want to grab info from in this Column, always populated
'if the cell is empty, search through the file for "Supplier Number : "
If IsEmpty(wks.Cells(rowT, 19)) Then
Set wb = Workbooks.Open(source)
wb.Activate
LastRowT = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = wks.Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
Range("A" & rowTT).Select
Selection.Copy
Windows("Get Supplier Number.xlsm").Activate
Range("A" & rowT).Select
wks.Paste
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
Next rrow
ScreenUpdating = True
End Sub
I get the pastespecial error 1004.
What is expected is that for each row in "Get Supplier Number.xlsm", the row's A column is updated with the information
Thank you for helping!
First of all you should get rid of Activate and Select methods. You don't have to use them and they give nothing to your code. Using them is not a good approach.
To avoid them you should use specific references. Which you are doing so, until a specific point. Inside the for loop, after setting the wb, replace everything with the following:
With wb.Worksheets(1)
LastRowT = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = .Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
.Range("A" & rowTT).Copy wks.Range("A" & rowT)
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
End With
I think this should do the job for you.
PS: If you need just the value of the cell in the opened workbook, then you could replace the Copy line with a simple equality:
wks.Range("A" & rowT) = .Range("A" & rowTT)

Excel - Merge worksheets with different structure

I have a Excel workbook with over 100 worksheets all of which have a different structure (some columns are in all of those worksheets, but some are not). Is there an easy way to merge the worksheets by the columns they have in common?
Thank you in advance!
Do the following:
Open the VBA Editor window
Click “Tools” from the File menu
Select “References” from within the Tools menu
Scroll down until you find “Microsoft Scripting Runtime”
Check the box next to the “Microsoft Scripting Runtime”
Click OK
Then paste this into an Excel vba module:
Option Explicit
Public Sub CombineSheetsWithDifferentHeaders()
Dim wksDst As Worksheet, wksSrc As Worksheet
Dim lngIdx As Long, lngLastSrcColNum As Long, _
lngFinalHeadersCounter As Long, lngFinalHeadersSize As Long, _
lngLastSrcRowNum As Long, lngLastDstRowNum As Long
Dim strColHeader As String
Dim varColHeader As Variant
Dim rngDst As Range, rngSrc As Range
Dim dicFinalHeaders As Scripting.Dictionary
Set dicFinalHeaders = New Scripting.Dictionary
'Set references up-front
dicFinalHeaders.CompareMode = vbTextCompare
lngFinalHeadersCounter = 1
lngFinalHeadersSize = dicFinalHeaders.Count
Set wksDst = ThisWorkbook.Worksheets.Add
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Start Phase 1: Prepare Final Headers and Destination worksheet'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'First, we loop through all of the data worksheets,
'building our Final Headers dictionary
For Each wksSrc In ThisWorkbook.Worksheets
'Make sure we skip the Destination worksheet!
If wksSrc.Name <> wksDst.Name Then
With wksSrc
'Loop through all of the headers on this sheet,
'adding them to the Final Headers dictionary
lngLastSrcColNum = LastOccupiedColNum(wksSrc)
For lngIdx = 1 To lngLastSrcColNum
'If this column header does NOT already exist in the Final
'Headers dictionary, add it and increment the column number
strColHeader = Trim(CStr(.Cells(1, lngIdx)))
If Not dicFinalHeaders.Exists(strColHeader) Then
dicFinalHeaders.Add Key:=strColHeader, _
Item:=lngFinalHeadersCounter
lngFinalHeadersCounter = lngFinalHeadersCounter + 1
End If
Next lngIdx
End With
End If
Next wksSrc
'Wahoo! The Final Headers dictionary now contains every column
'header name from the worksheets. Let's write these values into
'the Destination worksheet and finish Phase 1
For Each varColHeader In dicFinalHeaders.Keys
wksDst.Cells(1, dicFinalHeaders(varColHeader)) = CStr(varColHeader)
Next varColHeader
'''''''''''''''''''''''''''''''''''''''''''''''
'End Phase 1: Final Headers are ready to rock!'
'''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Start Phase 2: write the data from each worksheet to the Destination!'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'We begin just like Phase 1 -- by looping through each sheet
For Each wksSrc In ThisWorkbook.Worksheets
'Once again, make sure we skip the Destination worksheet!
If wksSrc.Name <> wksDst.Name Then
With wksSrc
'Identify the last row and column on this sheet
'so we know when to stop looping through the data
lngLastSrcRowNum = LastOccupiedRowNum(wksSrc)
lngLastSrcColNum = LastOccupiedColNum(wksSrc)
'Identify the last row of the Destination sheet
'so we know where to (eventually) paste the data
lngLastDstRowNum = LastOccupiedRowNum(wksDst)
'Loop through the headers on this sheet, looking up
'the appropriate Destination column from the Final
'Headers dictionary and creating ranges on the fly
For lngIdx = 1 To lngLastSrcColNum
strColHeader = Trim(CStr(.Cells(1, lngIdx)))
'Set the Destination target range using the
'looked up value from the Final Headers dictionary
Set rngDst = wksDst.Cells(lngLastDstRowNum + 1, _
dicFinalHeaders(strColHeader))
'Set the source target range using the current
'column number and the last-occupied row
Set rngSrc = .Range(.Cells(2, lngIdx), _
.Cells(lngLastSrcRowNum, lngIdx))
'Copy the data from this sheet to the destination!
rngSrc.Copy Destination:=rngDst
Next lngIdx
End With
End If
Next wksSrc
'Yay! Let the user know that the data has been combined
MsgBox "Data combined!"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
Then run the macro.
Original source adapted from: https://danwagner.co/how-to-combine-data-with-different-columns-on-multiple-sheets-into-a-single-sheet/

Copy/Paste Many Sheets of Data using xlDown and Copy PasteSpecial

I am trying to copy a lot of data from many sheets to another and the line: toSheet.Range(Cells(toRow, toCol), Cells(toRow, toCol)).PasteSpecial xlPasteValues keeps failing with "Runtime Error 1004 You can;t paste here b/c copy paste size are not same ... Select just one cell ..."
I don't know how to fix this. The whole point of this is to not "select" anything at all! I am trying to avoid using selections.
Option Explicit
Sub CopyFastenerMargins()
Dim StartTime As Double 'track code run time
Dim secondsElapsed As Double
StartTime = Timer
Application.ScreenUpdating = False 'turn off blinking
Dim nameRange As Range, r As Range, sht As Range
Dim fromSheet As Worksheet, toSheet As Worksheet, sheetName As String
Dim fromRow As Long, fromCol As Long, LCID As Variant
Dim toRow As Long, toCol As Long, rowCount As Long
Dim FSY As Range, FSYvalue As Double
Dim FSU As Range, FSUvalue As Double
Dim analysisType As String, analysisFlag As Integer
'Set range containing worksheet names to loop thru
Set nameRange = Worksheets("TOC").Range("A44:A82")
'Set destination worksheet
Set toSheet = Sheets("SuperMargins")
'find data and copy to destination sheet
'Loop thru sheets
Dim i As Long
For i = 1 To 3
'pickup current sheet name
sheetName = nameRange(i)
Set fromSheet = Sheets(sheetName)
'find starting location (by header) of data and set range
Set r = fromSheet.Cells.Find(What:="Minimums by LCID", After:=fromSheet.Cells(1, 1), Lookat:=xlWhole, MatchCase:=True)
Set r = r.Offset(2, -1)
fromRow = r.Row
fromCol = r.Column
'set row column indices on destination sheet
toCol = 2
toRow = lastRow(toSheet) + 1 'get last row using function
'Copy LCID Range
fromSheet.Activate
fromSheet.Range(Cells(fromRow, fromCol), Cells(fromRow, fromCol).End(xlDown)).Copy
toSheet.Activate
**'********************************NEXT LINE THROWS ERROR**
toSheet.Range(Cells(toRow, toCol), Cells(toRow, toCol)).PasteSpecial xlPasteValues
Application.ScreenUpdating = True
secondsElapsed = Round(Timer - StartTime, 2)
MsgBox ("Done. Time: " & secondsElapsed)
End Sub
' function to determine last row of data
Function lastRow(sht As Worksheet) As Long
' source: http://stackoverflow.com/questions/11169445/error-finding-last-used-cell-in-vba
With sht
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastRow = 1
End If
End With
End Function
In this line,
fromSheet.Range(Cells(fromRow, fromCol), Cells(fromRow, fromCol).End(xlDown)).Copy
... the xlDown is going all the way to the bottom of the worksheeet. If fromRow was row 2 then this is 1,048,575 rows. If you now go to paste and you are starting where toRow is anything greater than fromRow then you do not have enough rows to receive the full copy.
Change the .Copy line to,
with fromSheet
.Range(.Cells(fromRow, fromCol), .Cells(.rows.count, fromCol).End(xlUp)).Copy
end with
By looking from the bottom up, you will still get all of your data and it is unlikely that you will run into the same problem (although theoretically possible).

Resources