I use the following code to combine multiple worksheets. The problem is, that this code works with worksheets that have title in the first row and my worksheets do not have. It is possible to select only 3 columns (A, F and G).. I mean the range from the woorksheets? The worksheets have the same structure only the number of lines may be different. Any idea? Thanks!
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
' copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Range("A1").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
' select all lines except title
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
Instead of copying only A, F+G you can delete all columns you don't need from the resulting sheet.
Sub Combine()
Dim jCt As Integer
Dim ws As Worksheets
Dim myRange As Range
Dim lastRow As Long
lastRow = 1
'Delete Worksheet combine if it exists
If sheetExists("Combined") Then
Application.DisplayAlerts = False
Sheets("Combined").Delete
Application.DisplayAlerts = True
MsgBox "Worksheet ""Combined"" deleted!"
End If
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
' work through sheets
For jCt = 2 To Sheets.Count ' from sheet 2 to last sheet
Set myRange = Sheets(jCt).Range(Sheets(jCt).Cells(1, 1), Sheets(jCt).Range("A1").SpecialCells(xlCellTypeLastCell))
Debug.Print Sheets(jCt).Name, myRange.Address
'Put the SheetName on the Sheet "Cominbed"
Sheets("Combined").Range("A1").Offset(lastRow, 0) = Sheets(jCt).Name
With Sheets("Combined").Range("A1").Offset(lastRow, 0).Font
.Bold = True
.Size = 14
End With
'copy the sheets
myRange.Copy Destination:=Sheets("Combined").Range("A1").Offset(lastRow + 2, 0)
lastRow = lastRow + myRange.Rows.Count + 3
Next
End Sub
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
Related
I have written a code which does the below steps.
1) Loops through a list of products
2) Auto filters the data with each product.
3) Copies and pastes data on to separate worksheets and names it with that product name.
4) Inserts a line at every change in schedule
The only thing I couldn't do it here is to limit separate worksheet creation only for the products available in the source data when auto filtered.
I tried to do this by adding an if condition to add worksheets by product name only if auto filter shows any data but for some reason it is not working.
I would appreciate any help in fixing this problem and clean my code to make it look better and work faster.
Sub runreport()
Dim rRange As Range
Dim Rng As Range
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
Next producttype
End Sub
Try this...
Sub runreport()
Dim rRange As Range
Dim Rng As Range
Dim FiltRows As Integer
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
With Workbooks("Source.xlsx").Sheets("Sheet1")
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
End With
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
Next producttype
End Sub
I would recommend you define more variables than you have it keeps the code cleaner and easier to read as well as eliminates easy errors.
I also recommend always to utilize "option explicit" at the top of every code. It forces defining all variables (when you don't define a variable the program will do it for you (assuming you haven't used option explicit), but excel doesn't always get it correct. Also option explicit helps you avoid typos in variables.
Also as a general rule you rarely if ever have to .select anything to do what you need to with vba.
Below is an example of a cleaned up and shortened code which utilized variable definition and instantiation.
Sub runreport()
Dim wb As Workbook
Dim wsSched As Worksheet
Dim wsNew As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rRange As Range
Dim producttype As Range
Dim Filename As String
Dim FiltRows As Integer
Dim myRow As Integer
'instantiate Variables
Set wb = ThisWorkbook
Set wsSched = wb.Worksheets("Schedule")
' Open the Source File
Filename = Application.GetOpenFilename()
Set wbSource = Workbooks.Open(Filename)
Set wsSource = wbSource.Worksheets("Sheet1")
'Loops through each product type range from the macro spreadsheet.
For Each producttype In wsSched.Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
With wsSource
.AutoFilterMode = False
.Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
'Add new workbook
Set wsNew = wb.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count))
'Copy filtered data including header
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
'Paste filterd data and header
wsNew.Range("A1").PasteSpecial
Application.CutCopyMode = False
wsNew.Columns.AutoFit
'Rename new worksheet
wsNew.Name = WorksheetFunction.VLookup(producttype, wb.Worksheets("Sheet2").Range("A:B"), 2, False)
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
End With
Next producttype
End Sub
First, you can check this answer for ways to optimize your vba code
As for your code in its current form, it would be easiest if you select the entire range of your product code data first. Then you can check this range after your filter and determine if all the rows are hidden. See a sample of the code below
Dim productData as Range
Set productData = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter _
Field:=4, Criteria1:=producttype
' The error check will skip the creation of a new sheet if the copy failed (i.e. returns a non-zero error number)
On Error Resume Next
' Copies only the visible cells
productData.SpecialCells(xlCellTypeVisible).Copy
If Err.number = 0 then
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = Application.VLookup(producttype, _
ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
Range("a2").Select
ActiveSheet.Paste
End If
While you can Range.Offset one row and check if the Range.SpecialCells method with xlCellTypeVisible is Not Nothing, I prefer to use the worksheet's SUBTOTAL function. The SUBTOTAL function discards hidden or filtered rows from its operations so a simple COUNTA (SUBTOTAL subfunction 103) of the cells below the header will tell you if there is anything available.
Sub runreport()
Dim rRange As Range, rHDR As Range, rVAL As Range, wsn As String
Dim fn As String, owb As Workbook, twb As Workbook
Dim i As Long, p As Long, pTYPEs As Variant
pTYPEs = ThisWorkbook.Sheets("Schedule").Range("Product").Value2
Set twb = ThisWorkbook
' Open the Source File
fn = Application.GetOpenFilename()
Set owb = Workbooks.Open(fn)
With owb
'is this Workbooks("Source.xlsx")?
End With
With Workbooks("Source.xlsx").Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
'store the header in case it is needed for a new worksheet
Set rHDR = .Rows(1).Cells
'reset the the filtered cells
Set rVAL = Nothing
For p = LBound(pTYPEs) To UBound(pTYPEs)
.AutoFilter Field:=4, Criteria1:=pTYPEs(p)
With .Resize(.Rows.Count - 1, 7).Offset(1, 0) '<~~resize to A:G and move one down off the header row
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible cells; do stuff here
Set rVAL = .Cells
wsn = Application.VLookup(pTYPEs(p), twb.Worksheets("Sheet2").Range("A:B"), 2, False)
'if the wsn worksheet doesn't exist, go make one and come back
On Error GoTo bm_New_Worksheet
With Worksheets(wsn)
On Error GoTo bm_Safe_Exit
rVAL.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'when inserting rows, always work from the bottom to the top
For i = .Cells(Rows.Count, 3).End(xlUp).Row To 3 Step -1
If .Cells(i, 3).Value2 <> .Cells(i - 1, 3).Value2 Then
.Rows(i).Insert
End If
Next i
'autofit the columns
For i = .Columns.Count To 1 Step -1
.Columns(i).AutoFit
Next i
End With
End If
End With
Next p
End With
End With
GoTo bm_Safe_Exit
bm_New_Worksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
rHDR.Copy Destination:=.Cells(1, 1)
End With
Resume
bm_Safe_Exit:
End Sub
When a worksheet that is referenced by the wsn string does not exist, the On Error GoTo bm_New_Worksheet runs off and creates one. The Resume brings the code processing right back to the place it errored out.
One caution when using this method is to ensure that you have unique, legal worksheet names returned by your VLOOKUP function.
I have used the below code but this takes all cells, including formula cells.
I tried to include SpecialCells(xlCellTypeVisible) , but wherever I seem to put it I cannot get it right.
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
' copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Range("A1").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
' select all lines except title
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
Good Morning chaps,
A few days after you asked this questions I was having similar issues with a Macro similar to this Jerry Sullivan
Gave me a hand try this it might work for you.
Option Explicit
Sub CombineData()
'--combines data from all sheets
' assumes all sheets have exact same header fields as the
' first sheet; however the fields may be different order.
'--combines using copy-paste. could be modified to pasteValues only
Dim lNdxSheet As Long, lNextRow As Long, lDestCol As Long
Dim lColCount As Long, lRowCount As Long
Dim rHeaders As Range
Dim sHeader As String
Dim vMatch As Variant, vHeaders As Variant
Dim wksCombined As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'--add new sheet for results
Set wksCombined = Worksheets.Add(Before:=Worksheets(1))
'--optional: delete existing sheet "Combined"
On Error Resume Next
Sheets("Combined").Delete
On Error GoTo 0
With wksCombined
.Name = "Combined"
'--copy headers that will be used in destination sheet
Set rHeaders = Sheets(2).Range("A1").CurrentRegion.Resize(1)
rHeaders.Copy Destination:=.Range("A1")
End With
'--read headers into array
vHeaders = rHeaders.Value
lColCount = UBound(vHeaders, 2)
lNextRow = 2
For lNdxSheet = 2 To Sheets.Count
'--count databody rows of continguous dataset at A1
lRowCount = Sheets(lNdxSheet).Range("A1").CurrentRegion.Rows.Count - 1
If lRowCount > 0 Then
For lDestCol = 1 To lColCount
sHeader = vHeaders(1, lDestCol)
'--search entire first col in case field is rSourceData
vMatch = Application.Match(sHeader, Sheets(lNdxSheet).Range("1:1"), 0)
If IsError(vMatch) Then
MsgBox "Header: """ & sHeader & """ not found on sheet: """ _
& Sheets(lNdxSheet).Name
GoTo ExitProc
End If
With Sheets(lNdxSheet)
'--copy-paste this field under matching field in combined
.Cells(2, CLng(vMatch)).Resize(lRowCount).Copy
' Option 1: paste values only
wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteValues)
' Option 2: paste all including formats and formulas
' wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteAll)
End With
Next lDestCol
lNextRow = lNextRow + lRowCount
End If ' lRowCount > 0
Next lNdxSheet
ExitProc:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I'm not sure if I understood your question correctly but try this and see if it helps.
I was reviewing the following code:
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
This code combines cells for reporting. This is supposed to copy the info from all the sheets to one combined sheet. However, if I have different headers i.e if in Sheet1!A1 is "Address" and in Sheet2!A1 is "Name", it will copy the names under the address.
Is there a way to have some sort of search so that it will only copy the exact headers and paste them under the correct one?
Here's an example...
Option Explicit
Sub CombineData()
'--combines data from all sheets
' assumes all sheets have exact same header fields as the
' first sheet; however the fields may be different order.
'--combines using copy-paste. could be modified to pasteValues only
Dim lNdxSheet As Long, lNextRow As Long, lDestCol As Long
Dim lColCount As Long, lRowCount As Long
Dim rHeaders As Range
Dim sHeader As String
Dim vMatch As Variant, vHeaders As Variant
Dim wksCombined As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'--add new sheet for results
Set wksCombined = Worksheets.Add(Before:=Worksheets(1))
'--optional: delete existing sheet "Combined"
On Error Resume Next
Sheets("Combined").Delete
On Error GoTo 0
With wksCombined
.Name = "Combined"
'--copy headers that will be used in destination sheet
Set rHeaders = Sheets(2).Range("A1").CurrentRegion.Resize(1)
rHeaders.Copy Destination:=.Range("A1")
End With
'--read headers into array
vHeaders = rHeaders.Value
lColCount = UBound(vHeaders, 2)
lNextRow = 2
For lNdxSheet = 2 To Sheets.Count
'--count databody rows of continguous dataset at A1
lRowCount = Sheets(lNdxSheet).Range("A1").CurrentRegion.Rows.Count - 1
If lRowCount > 0 Then
For lDestCol = 1 To lColCount
sHeader = vHeaders(1, lDestCol)
'--search entire first col in case field is rSourceData
vMatch = Application.Match(sHeader, Sheets(lNdxSheet).Range("1:1"), 0)
If IsError(vMatch) Then
MsgBox "Header: """ & sHeader & """ not found on sheet: """ _
& Sheets(lNdxSheet).Name
GoTo ExitProc
End If
With Sheets(lNdxSheet)
'--copy-paste this field under matching field in combined
.Cells(2, CLng(vMatch)).Resize(lRowCount).Copy
' Option 1: paste values only
wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteValues)
' Option 2: paste all including formats and formulas
' wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteAll)
End With
Next lDestCol
lNextRow = lNextRow + lRowCount
End If ' lRowCount > 0
Next lNdxSheet
ExitProc:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Trying to write a macro in VBA for Excel to look at the value in a certain column from each row of data in a list and if that value is "yes" then it copies and pastes the entire row onto a different sheet in the same workbook. Let's name the two sheets "Data" and "Final". I want to have the sheets referenced so it does not matter which sheet I have open when it runs the code. I was going to use a Do loop to cycle through the rows on the one data sheet until it finds there are no more entries, and if statements to check the values.
I am confused about how to switch from one sheet to the next.
How do I specifically reference cells in different sheets?
Here is the pseudocode I had in mind:
Do while DataCells(x,1).Value <> " "
for each DataCells(x,1).Value="NO"
if DataCells(x,2).Value > DataCells(x,3).Value or _
DataCells(x,4).Value < DataCells(x,5).Value
'Copy and paste/insert row x from Data to Final sheet adding a new
'row for each qualifying row
else
x=x+1
end
else if DataCells(x,1).Value="YES"
Loop
'copy and paste entire row to a third sheet
'continue this cycle until all rows in the data sheet are examined
Sub FilterAndCopy()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Set sh = ThisWorkbook.Sheets("Data")
Set sh2 = ThisWorkbook.Sheets("Final")
lastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).Row ' Replace "A" With column that has the most Rows
lastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column
With sh.Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1))
'Replace the number in the field section with your Columns number
.AutoFilter , _
Field:=1, _
Criteria1:="yes"
.Copy sh2.Range("A1")
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Hello to the community and thank you in advance for your assistance. I have created a workbook that has a variable number of worksheets most of which have variable name. There are however, 4 worksheets that will not change and I do not want data copied from them. The code I am attempting is below: If I am way off base, please let me know.
V/R
Doug
Private Sub GroupReport_Click()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim Disreguard(1 To 4) As String
Disreguard(1) = "RDBMergeSheet"
Disreguard(2) = "0 Lists"
Disreguard(3) = "0 MasterCrewSheet"
Disreguard(4) = "00 Overview"
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> Disreguard.Worksheets.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Rows("21")
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next
Unfortunately, this line will not work for you:
If sh.Name <> Disreguard.Worksheets.Name Then
The Disreguard variable is an array, but not an object in VBA, so there are no methods you can access with the dot operator. You would have to loop through the array's contents and check each item against the string you're testing.
You can add a function to test it like this:
Private Function toDisreguard(ByRef list() as String, ByRef searchString As String) As Boolean
Dim i As Long
For i = LBound(list) To UBound(list)
If (searchString = list(i)) Then
toDisreguard = True
Exit Function
End If
Next i
toDisreguard = False
End Function
And then pass the array along with the sheet name to test like so:
If (toDisreguard(Disreguard, sh.Name) = False) Then
Also, the LastRow() function is not defined from what you posted. Is this a function you created?
In fact, you could just keep track of the last row yourself since you're rebuilding the "RDBMergeSheet" worksheet each time you run this. You can start by setting Last = 1 and then increment along the way. And one last thing, you should probably test to see if there is any data in row 21 for each sheet so you're not copying a blank row:
' Loop through all worksheets and copy the data to the
' summary worksheet.
Last = 1
For Each sh In ActiveWorkbook.Worksheets
If (toDisreguard(Disreguard, sh.Name) = False) Then
'Last = LastRow(DestSh)
If (Application.WorksheetFunction.CountA(sh.Rows("21")) > 0) Then
Set CopyRng = sh.Rows("21")
CopyRng.Copy
With DestSh.Cells(Last, "A") ' notice i changed this as well
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Last = Last + 1
End If
End If
Next