Pasting to Another Workbook VBA

[DBaker7777]

I have the below code and it works fine, but right now it is not copying all the "New" rows at once and pasting them. It copies one row, opens the workbook, saves, closes the workbook then if it finds another row labeled "New" it repeats the process. This would take a long time if 100's of rows have "New" in them. Is there anyway to grab them all at once and paste them over? Thank you

Sub myData()
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 1).Value = "NEW" Then
Range(Cells(i, 2), Cells(i, 13)).Select
Selection.Copy
Workbooks.Open Filename:="C:\History\Archive.xlsm"

Worksheets("Sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub

 

[Fluff]

How about

Sub myData()
   Dim LastRow As Long, i As Long
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   
   Set Ws = ActiveSheet
   Set Wbk = Workbooks.Open(FileName:="C:\History\Archive.xlsm")
   
   LastRow = Ws.Range("A" & Rows.Count).End(xlUp).Row
   For i = 2 To LastRow
      If Ws.Cells(i, 1).Value = "NEW" Then
         Ws.Range(Ws.Cells(i, 2), Ws.Cells(i, 13)).Copy
         
         With Wbk.Worksheets("Sheet1")
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
         End With
         Application.CutCopyMode = False
      End If
   Next i
   Wbk.Close True
End Sub

 

[DBaker7777]

How about

Sub myData()
   Dim LastRow As Long, i As Long
   Dim Wbk As Workbook
   Dim Ws As Worksheet
  
   Set Ws = ActiveSheet
   Set Wbk = Workbooks.Open(FileName:="C:\History\Archive.xlsm")
  
   LastRow = Ws.Range("A" & Rows.Count).End(xlUp).Row
   For i = 2 To LastRow
      If Ws.Cells(i, 1).Value = "NEW" Then
         Ws.Range(Ws.Cells(i, 2), Ws.Cells(i, 13)).Copy
        
         With Wbk.Worksheets("Sheet1")
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
         End With
         Application.CutCopyMode = False
      End If
   Next i
   Wbk.Close True
End Sub

Worked Perfectly. Thank you

 

[Fluff]

You're welcome & thanks for the feedback.

 

[DBaker7777]

Quick follow up. If there were no rows that contained "NEW" where would I put this at?

MsgBox "No data to export at this time"
exit sub

 

[Fluff]

How about

Sub myData()
   Dim LastRow As Long, i As Long, x As Long
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   
   Set Ws = ActiveSheet
   Set Wbk = Workbooks.Open(FileName:="C:\History\Archive.xlsm")
   
   LastRow = Ws.Range("A" & Rows.Count).End(xlUp).Row
   For i = 2 To LastRow
      If Ws.Cells(i, 1).Value = "NEW" Then
         x = x + 1
         Ws.Range(Ws.Cells(i, 2), Ws.Cells(i, 13)).Copy
         
         With Wbk.Worksheets("Sheet1")
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
         End With
         Application.CutCopyMode = False
      End If
   Next i
   Wbk.Close True
   If x = 0 Then
      MsgBox "No data to export at this time"
   Else
      MsgBox x & "Rows copied"
   End If
End Sub

 

[DBaker7777]

It still goes through opening the History and closing History (it does not paste anything though). I wanted to catch it before it did all that and exit sub with a message box.

 

[Fluff]

Ok, how about

Sub myData()
   Dim LastRow As Long, i As Long
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   
   Set Ws = ActiveSheet
   
   LastRow = Ws.Range("A" & Rows.Count).End(xlUp).Row
   If Application.CountIf(Ws.Columns(1), "NEW") = 0 Then
      MsgBox "No data to export at this time"
      Exit Sub
   End If
   Set Wbk = Workbooks.Open(FileName:="C:\History\Archive.xlsm")
   For i = 2 To LastRow
      If Ws.Cells(i, 1).Value = "NEW" Then
         Ws.Range(Ws.Cells(i, 2), Ws.Cells(i, 13)).Copy
         
         With Wbk.Worksheets("Sheet1")
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
         End With
         Application.CutCopyMode = False
      End If
   Next i
   Wbk.Close True
End Sub

 

[DBaker7777]

Again, Thank you. This did it!

 

[Fluff]

Glad to help & thanks for the feedback.