Excel VBA - copy row to new sheet

O

omnivl

Board Regular
Joined
Aug 25, 2014
Messages
53
Currently my code looks for "Invoice" in column A and copies the row to a new workbook. Works well. However, i need to capture the Reference name and number for that invoice number. Any help would be welcomed :)

Currently it looks like so:

Invoice430412298115992.1100115992.1100

<tbody>
</tbody>

However i need it to capture

Invoice430412298115992.1100115992.1100V00859Automotive & Engineering P/L

<tbody>
</tbody>


My code
Code: 
Sub copyBurnDownItem()

Dim srcWorkbook As Workbook
Dim desWorkbook As Workbook
Dim objWorksheet As Worksheet
Dim objNewSheet As Worksheet
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim rngNextAvailbleRow As Range

Set desWorkbook = Workbooks.Open("C:\test\master_audit.xlsm")
Set srcWorkbook = Workbooks.Open("C:\test\current.xlsx")
Set objWorksheet = srcWorkbook.Worksheets("Sheet1")

'Clear data
desWorkbook.Sheets("import").Cells.Clear
srcWorkbook.Activate

'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells
srcWorkbook.Activate
objWorksheet.Select

If rngCell.Value = "Invoice" Then
    'select the entire row
    rngCell.EntireRow.Select

    'copy the selection
    Selection.Copy

    'Now identify and select the new sheet to paste into
    Set objNewSheet = desWorkbook.Worksheets("import")
    desWorkbook.Activate
    objNewSheet.Select

   
    Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
    
    Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
    'ActiveSheet.PasteSpecial Operation:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

'Can do some basic error handing here
srcWorkbook.Activate
Application.DisplayAlerts = False
srcWorkbook.Close
Application.DisplayAlerts = True
desWorkbook.Activate


'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub

Sample data

Type
DateReferenceCurrency CodeOriginal AmountPreviously AppliedWithholding Tax DeductedThis PaymentThis Payment DiscountBalance Due
Invoice2/11/20172298115,992.110.000.00115,992.110.000.00
V00859Automotive & Engineering P/L
115,992.11
Invoice1/09/2017DEBTOR 25301 JULY 2017772.000.000.00772.000.000.00
Invoice20/10/2017PJ000173328.05
0.000.00328.050.000.00
Invoice3/11/2017PJ000179275.580.000.00
275.580.000.00
V00054Jumble Jim

<colgroup><col style="width:43pt" span="2" width="57"> <col style="width:128pt" width="170"> <col style="width:8pt" width="11"> <col style="width:39pt" width="52"> <col style="width:50pt" span="2" width="66"> <col style="width:2pt" width="2"> <col style="width:50pt" span="2" width="66"> <col style="width:9pt" width="12"> <col style="width:41pt" width="55"> <col style="width:6pt" width="8"> <col style="width:5pt" width="7"> <col style="width:21pt" width="28"> <col style="width:2pt" width="3"> <col style="width:13pt" width="17"> <col style="width:1pt" width="1"> <col style="width:2pt" width="2"> </colgroup><tbody>
</tbody>
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Sort by date Sort by votes
Try
Code: 
Sub copyBurnDownItem()

    Dim srcWorkbook As Workbook
    Dim desWorkbook As Workbook
    Dim objWorksheet As Worksheet
    Dim objNewSheet As Worksheet
    Dim rngBurnDown As Range
    Dim rngCell As Range
    Dim strPasteToSheet As String
    
    'Used for the new worksheet we are pasting into
    Dim rngNextAvailbleRow As Long
    
    Set desWorkbook = Workbooks.Open("C:\test\master_audit.xlsm")
    Set srcWorkbook = Workbooks.Open("C:\test\current.xlsx")
    Set objWorksheet = srcWorkbook.Worksheets("Sheet1")
    Set objNewSheet = desWorkbook.Worksheets("import")
    
    'Clear data
    objNewSheet.Cells.Clear
    
    'Dynamically define the range to the last cell.
    'This doesn't include and error handling e.g. null cells
    'If we are not starting in A1, then change as appropriate
    Set rngBurnDown = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
    
    'Now loop through all the cells in the range
    For Each rngCell In rngBurnDown.Cells
        If rngCell.Value = "Invoice" Then
            rngNextAvailbleRow = objNewSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
            'select the entire row
            rngCell.EntireRow.Copy objNewSheet.Range("A" & rngNextAvailbleRow)
            If rngCell.Offset(1) = "" And rngCell.Offset(1, 1) <> "" Then
                rngCell.Offset(1, 1).Resize(, 2).Copy Range("N" & rngNextAvailbleRow)
            End If
        End If
    Next rngCell
    
    objWorksheet.Select
    objWorksheet.Cells(1, 1).Select
    
    'Can do some basic error handing here
    srcWorkbook.Activate
    Application.DisplayAlerts = False
    srcWorkbook.Close
    Application.DisplayAlerts = True
    desWorkbook.Activate
    
    
    'kill all objects
    If IsObject(objWorksheet) Then Set objWorksheet = Nothing
    If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
    If IsObject(rngCell) Then Set rngCell = Nothing
    If IsObject(objNewSheet) Then Set objNewSheet = Nothing
    If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub
As you haven't said where you want the Data I've guessed from your example that it should in cols N & O
 
Upvote 0
Hi

Thanks for the response, i get this error at Set objNewSheet = "object variable or with block variable not set"

Thanks
 
Upvote 0
Do you have a sheet called import in the master_audit.xlsm file?
Also is the master_audit.xlsm file open?
 
Upvote 0
Ok, could you Open the file & select the import sheet. Then run this code & post back exactly what the msgbox says
Code: 
Sub chk()
MsgBox "|" & ActiveSheet.Name & "|"
End Sub
 
Upvote 0
Odd. To get the error, you've received, I would either expect the workbook to be closed, or the sheet not to exist.
Could you please try
Code: 
Sub copyBurnDownItem()

    Dim srcWorkbook As Workbook
    Dim desWorkbook As Workbook
    Dim objWorksheet As Worksheet
    Dim objNewSheet As Worksheet
    Dim rngBurnDown As Range
    Dim rngCell As Range
    Dim strPasteToSheet As String
    
    'Used for the new worksheet we are pasting into
    Dim rngNextAvailbleRow As Long
    
    Set desWorkbook = Workbooks.Open("C:\test\master_audit.xlsm")
    Set srcWorkbook = Workbooks.Open("C:\test\current.xlsx")
    Set objWorksheet = srcWorkbook.Worksheets("Sheet1")
    [COLOR=#0000ff]MsgBox desWorkbook.FullName[/COLOR]
    Set objNewSheet = desWorkbook.Worksheets("import")
    
    'Clear data
    objNewSheet.Cells.Clear
    
    'Dynamically define the range to the last cell.
    'This doesn't include and error handling e.g. null cells
    'If we are not starting in A1, then change as appropriate
    Set rngBurnDown = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
    
    'Now loop through all the cells in the range
    For Each rngCell In rngBurnDown.Cells
        If rngCell.Value = "Invoice" Then
            rngNextAvailbleRow = objNewSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
            'select the entire row
            rngCell.EntireRow.copy objNewSheet.Range("A" & rngNextAvailbleRow)
            If rngCell.Offset(1) = "" And rngCell.Offset(1, 1) <> "" Then
                rngCell.Offset(1, 1).Resize(, 2).copy Range("N" & rngNextAvailbleRow)
            End If
        End If
    Next rngCell
    
    objWorksheet.Select
    objWorksheet.Cells(1, 1).Select
    
    'Can do some basic error handing here
    srcWorkbook.Activate
    Application.DisplayAlerts = False
    srcWorkbook.Close
    Application.DisplayAlerts = True
    desWorkbook.Activate
    
    
    'kill all objects
    If IsObject(objWorksheet) Then Set objWorksheet = Nothing
    If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
    If IsObject(rngCell) Then Set rngCell = Nothing
    If IsObject(objNewSheet) Then Set objNewSheet = Nothing
'    If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub
A msgbox should appear with the name & path of the destination workbook, does it?
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
compile, copy, pastespecial
Replies
2
Views
346
josephgunter163
J
K
  • Question
Multiple emails with each row data
Replies
1
Views
689
starl
starl
J
  • Question
Copy data from lastrow to first empty row on new sheet created
Replies
7
Views
899
JLGWhiz
JLGWhiz
B
  • Question
Excel VBA inconsistent errors when trying to copy and paste objects from Excel to Word
2
Replies
18
Views
33K
Jon Peltier
J
W
  • Question
hy doeso the code changes the table when it is selected instead of copying to new worksheet
Replies
0
Views
456
wondering101
W

Forum statistics

Threads
1,214,985
Messages
6,122,606
Members
449,089
Latest member
Motoracer88

Share this page

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