Pasting to Another Workbook VBA

DBaker7777

New Member
Joined
Feb 3, 2009
Messages
37
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

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,643
Office Version
  1. 365
Platform
  1. Windows
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
 

DBaker7777

New Member
Joined
Feb 3, 2009
Messages
37
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,643
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

DBaker7777

New Member
Joined
Feb 3, 2009
Messages
37

ADVERTISEMENT

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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,643
Office Version
  1. 365
Platform
  1. Windows
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
 

DBaker7777

New Member
Joined
Feb 3, 2009
Messages
37

ADVERTISEMENT

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,643
Office Version
  1. 365
Platform
  1. Windows
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
 
Solution

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,643
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,751
Messages
5,638,145
Members
417,010
Latest member
jnuss03

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
Top