Pasting to Another Workbook VBA

DBaker7777

Board Regular
Joined
Feb 3, 2009
Messages
53
Office Version
  1. 365
  2. 2016
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

VBA Code:
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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
How about
VBA Code:
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
 
Upvote 0
How about
VBA Code:
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
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0
Quick follow up. If there were no rows that contained "NEW" where would I put this at?
VBA Code:
MsgBox "No data to export at this time"
exit sub
 
Upvote 0
How about
VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
Ok, how about
VBA Code:
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
 
Upvote 0
Solution
Glad to help & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,202
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top