Help with Macro to Copy/Paste data below existing data

[fernanpr]

I know there are several threads about this but I couldn't find one to work for me so here goes. Below is the code I created using the Record Macro tool to save all the selected data from one sheet to another but I cannot figure out how to copy/paste new data below the existing data and not over it. I have used the code in red below on other spreadsheets before and this has worked but on this new spreadsheet I'm copying 60 rows of data per run and I think that might be the problem...

Also, I wish to not copy/paste rows that have blank cells and was trying an If statement but couldn't make it work... Otherwise I just end up having to manually delete the rows with blank spaces in them.

What do you recommend?

Sub PCLitesHistorical()
'
' PCLitesHistorical Macro
'
Dim i As Integer
Dim Ans As String


Ans = MsgBox("Are you sure you want to save data?", vbYesNo, "Are you sure?")


If Ans = vbYes Then
Application.ScreenUpdating = False 'This keeps the screen the same while the code executes


Sheets("PCLites Historical").Select
Range("B2:K2").Select

i = 1
Do Until Range("B2").Offset(i, 0).Value = ""
i = i + 1
Loop

Sheets("SMP PCLites").Select
Range("D6:H25,D31:H50,D56:H75").Select
Selection.Copy
Sheets("PCLites Historical").Select
Range("B3").Select
ActiveSheet.Paste

Sheets("SMP PCLites").Select
Range("C4:L4").Select
Selection.Copy
Sheets("PCLites Historical").Select
Range("G3:G22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("SMP PCLites").Select
Range("C29").Select
Selection.Copy
Sheets("PCLites Historical").Select
Range("G23:G42").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("SMP PCLites").Select
Range("C54").Select
Selection.Copy
Sheets("PCLites Historical").Select
Range("G43:G62").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("SMP PCLites").Select
Range("I6:L25,I31:L50,I56:L75").Select
Selection.Copy
Sheets("PCLites Historical").Select
Range("H3").Select
ActiveSheet.Paste
Range("B3").Select

Application.CutCopyMode = False
Sheets("SMP PCLites").Select
Range("D6").Select

Application.ScreenUpdating = True
ActiveWorkbook.Save

Ans = MsgBox("Data saved.", vbOKOnly, "Thanks.")


End If


End Sub

Appreciate the help in advance.
Thanks.

 

[Max1616]

Here is the code assuming all these sheets are in the same workbook. If one of the sections is blank it will just skip it all together. It also runs both sections at once so if you want to split them into seperate macros let me know and I'll split them for you:

Sub Fernanpr()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim i As Integer
Dim lrow As Integer
Dim lrow2 As Integer
Dim Counter As Integer
Dim Srow As Integer

Set ws1 = Sheets("SMP PCLites")
Set ws2 = Sheets("PCLites Historical")
Set ws3 = Sheets("SMP Seed Drumming")
Set ws4 = Sheets("Drumming Historical")


'C5:L35 of SMP PCLites to B:L of PCLites Historical
If WorksheetFunction.CountIf(ws1.Range("C5:C35"), "*") + WorksheetFunction.Sum(ws1.Range("C5:C35")) = 0 Then GoTo NextS1
If Len(ws2.Range("B3")) = 0 Then
Srow = 3
Else
Srow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
End If

For i = 5 To 35
    For Counter = 3 To 12
        If Len(ws1.Cells(i, Counter)) = 0 Then GoTo Nexti1
    Next Counter
    If Len(ws2.Range("B3")) = 0 Then lrow = 3
    If Len(ws2.Range("B3")) <> 0 Then lrow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
    ws1.Range(ws1.Cells(i, 3), ws1.Cells(i, 12)).Copy Destination:=ws2.Cells(lrow, 2)
Nexti1:
Next i

ws2.Cells(Srow, 14) = ws1.Range("G36")
ws2.Cells(Srow, 13) = Date
ws2.Columns(13).AutoFit
NextS1:


'C6:L55 of SMP PCLites to B:J of Drumming Historical
If WorksheetFunction.CountIf(ws3.Range("C6:C55"), "*") + WorksheetFunction.Sum(ws3.Range("C6:C55")) = 0 Then GoTo NextS2
If Len(ws4.Range("B3")) = 0 Then
Srow = 3
Else
Srow = ws4.Cells(Rows.Count, 2).End(xlUp).Row + 1
End If

For i = 6 To 55
    For Counter = 3 To 11
        If Len(ws3.Cells(i, Counter)) = 0 Then GoTo Nexti2
    Next Counter
    If Len(ws4.Range("B3")) = 0 Then lrow = 3
    If Len(ws4.Range("B3")) <> 0 Then lrow = ws4.Cells(Rows.Count, 2).End(xlUp).Row + 1
    If i = 6 Then Srow = lrow
    ws3.Range(ws3.Cells(i, 3), ws3.Cells(i, 11)).Copy Destination:=ws4.Cells(lrow, 2)
Nexti2:
Next i

ws4.Cells(Srow, 13) = ws3.Range("J56")
ws4.Cells(Srow, 12) = Date
ws4.Columns(12).AutoFit
NextS2:

End Sub

Let me know if this doesn't work.

Sincerely,
-Max

 

[fernanpr]

Max,

It worked perfectly. You are extremely good at this. My skills can't even be compared.

Yes, if you wouldn't mind, could you split them up so that I can assign the Macros to two separate buttons one in worksheet 1 and the other one in worksheet 3?

Thanks a lot!
Fernando

 

[Max1616]

Here you go!

Sub SMP_PCLites()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim i As Integer
Dim lrow As Integer
Dim lrow2 As Integer
Dim Counter As Integer
Dim Srow As Integer

Set ws1 = Sheets("SMP PCLites")
Set ws2 = Sheets("PCLites Historical")
Set ws3 = Sheets("SMP Seed Drumming")
Set ws4 = Sheets("Drumming Historical")


'C5:L35 of SMP PCLites to B:L of PCLites Historical
If WorksheetFunction.CountIf(ws1.Range("C5:C35"), "*") + WorksheetFunction.Sum(ws1.Range("C5:C35")) = 0 Then GoTo NextS1
If Len(ws2.Range("B3")) = 0 Then
Srow = 3
Else
Srow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
End If

For i = 5 To 35
    For Counter = 3 To 12
        If Len(ws1.Cells(i, Counter)) = 0 Then GoTo Nexti1
    Next Counter
    If Len(ws2.Range("B3")) = 0 Then lrow = 3
    If Len(ws2.Range("B3")) <> 0 Then lrow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
    ws1.Range(ws1.Cells(i, 3), ws1.Cells(i, 12)).Copy Destination:=ws2.Cells(lrow, 2)
Nexti1:
Next i

ws2.Cells(Srow, 14) = ws1.Range("G36")
ws2.Cells(Srow, 13) = Date
ws2.Columns(13).AutoFit
NextS1:

End Sub

Sub SMP_Seed_Drumming()


Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim i As Integer
Dim lrow As Integer
Dim lrow2 As Integer
Set ws3 = Sheets("SMP Seed Drumming")
Set ws4 = Sheets("Drumming Historical")

'C6:L55 of SMP PCLites to B:J of Drumming Historical
If WorksheetFunction.CountIf(ws3.Range("C6:C55"), "*") + WorksheetFunction.Sum(ws3.Range("C6:C55")) = 0 Then GoTo NextS2
If Len(ws4.Range("B3")) = 0 Then
Srow = 3
Else
Srow = ws4.Cells(Rows.Count, 2).End(xlUp).Row + 1
End If

For i = 6 To 55
    For Counter = 3 To 11
        If Len(ws3.Cells(i, Counter)) = 0 Then GoTo Nexti2
    Next Counter
    If Len(ws4.Range("B3")) = 0 Then lrow = 3
    If Len(ws4.Range("B3")) <> 0 Then lrow = ws4.Cells(Rows.Count, 2).End(xlUp).Row + 1
    If i = 6 Then Srow = lrow
    ws3.Range(ws3.Cells(i, 3), ws3.Cells(i, 11)).Copy Destination:=ws4.Cells(lrow, 2)
Nexti2:
Next i

ws4.Cells(Srow, 13) = ws3.Range("J56")
ws4.Cells(Srow, 12) = Date
ws4.Columns(12).AutoFit
NextS2:

End Sub

Glad I could help!

 

[fernanpr]

Awesome! Just tried it. Works perfectly!

Thanks again,
Fernando