Copy a range of cells from 2 worksheets and paste into 1 worksheet using same workbook using VBA

[Msears]

Hello All, I am wanting to copy a range of cells (A2:L500) from worksheets "JUL" and "AUG" and paste the date into worksheet ("1st Qtr"). Ideally, I want it to copy the range of data from Jul paste values & formats in the same range, next empty row in 1st Qtr, then copy the same range in Aug and paste the data below Jul in the 1st Qtr sheet. Is this possible using VBA? Thanks in advance!

 

[breynolds0431]

Hello All, I am wanting to copy a range of cells (A2:L500) from worksheets "JUL" and "AUG" and paste the date into worksheet ("1st Qtr"). Ideally, I want it to copy the range of data from Jul paste values & formats in the same range, next empty row in 1st Qtr, then copy the same range in Aug and paste the data below Jul in the 1st Qtr sheet. Is this possible using VBA? Thanks in advance!

Hello - try this:

Sub copymonth()

'sets sheet array for months, can update to include additional months
Dim shts As Variant: shts = Array(Sheets("July"), Sheets("August"))
'declares 1st Qtr worksheet
Dim qtr1 As Worksheet: Set qtr1 = ThisWorkbook.Sheets("1st Qtr")
'general declarations
Dim Q1lrow As Long, sh As Worksheet, i As Long

'find last row in 1st Qtr sheet based on column A (revise to suit)
Q1lrow = qtr1.Cells(qtr1.Rows.Count, "A").End(xlUp).Row

'loops through shts array copying specified range to 1st Qtr tab
For i = LBound(shts) To UBound(shts)
    With shts(i)
        .Range("A2:L500").Copy
        qtr1.Cells(Q1lrow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    End With
    'updates last row on 1st Qtr tab
    Q1lrow = qtr1.Cells(qtr1.Rows.Count, "A").End(xlUp).Row
Next i

'resets Q1 last row
Q1lrow = vbNull

End Sub

 

[Msears]

Hello - try this:

Sub copymonth()

'sets sheet array for months, can update to include additional months
Dim shts As Variant: shts = Array(Sheets("July"), Sheets("August"))
'declares 1st Qtr worksheet
Dim qtr1 As Worksheet: Set qtr1 = ThisWorkbook.Sheets("1st Qtr")
'general declarations
Dim Q1lrow As Long, sh As Worksheet, i As Long

'find last row in 1st Qtr sheet based on column A (revise to suit)
Q1lrow = qtr1.Cells(qtr1.Rows.Count, "A").End(xlUp).Row

'loops through shts array copying specified range to 1st Qtr tab
For i = LBound(shts) To UBound(shts)
    With shts(i)
        .Range("A2:L500").Copy
        qtr1.Cells(Q1lrow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    End With
    'updates last row on 1st Qtr tab
    Q1lrow = qtr1.Cells(qtr1.Rows.Count, "A").End(xlUp).Row
Next i

'resets Q1 last row
Q1lrow = vbNull

End Sub

Thanks so much!