VBA code to copy in a mirror image

D

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,392
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have some code to copy rows in a table (npss_quote) in one sheet (npss_quote_sheet) to a table (tblCosting) in another sheet (Costing_tool). In npss_quote there are 3 rows of data and when I copy them to tblCosting they become 4 rows. The forth row is blank with zeros but I want it to be a mirror image of the rows in npss_quote. How do I get this code to do just that, copy the three rows in npss_quote to be three rows tblCosting?

Code: 
Private Sub CmdSend_Click()
    Application.ScreenUpdating = False 'prevents screen flickering and speeds up the macro
    Application.EnableEvents = False 'prevents event macros from running which speeds up the macro and can avoid unwanted results or errors
    Dim desWS As Worksheet
    Dim srcWS As Worksheet
    Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet") 'source worksheet
    Set desWS = ThisWorkbook.Sheets("Costing_tool") 'destination worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim x As Long
    Dim header As Range 'defines 'header' as a range variable that will hold the header name found in "Costing_tool"
    lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row 'finds last used row in column B of "NPSS_quote_sheet"
    lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'finds last used row in column A of "Costing_tool"
    With srcWS.Range("A:A,B:B,H:H") 'columns to copy
        If lastRow2 < 5 Then 'checks if there is any data already copied in "Costing_tool" starting at row 5
            lastRow2 = 5 'if no data, sets last row to 5 and continues to next line of code, otherwise goes to 'Else' line of code
            For i = 1 To .Areas.Count 'loops through columns A, B and H
                x = .Areas(i).Column 'x represents the column number
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole) 'finds the header (row 10) in "Costing_tool"
                If Not header Is Nothing Then ' if found, executes next line of code
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy 'copies range starting in row 11 to lastrow in column
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'pastes value to corresponding column in "Costing_tool"
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then 'Checks to see if there is more than one row of data and if so, executes next line
                    desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas
                End If
                'next 3 lines find the range that needs to be filled with G7, B7 and B6 of "NPSS_quote_sheet" in columns D, F and G in "Costing_tool"
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else 'if data already existed, executes next line of code; see above for explanatory comments
            lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ''finds last used row in column A of "Costing_tool"
            desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas Can you explain this line of code with a comment please?
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole) 'finds the headers in columns A, B and H in row 4 columns A, B and H
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy 'Copies the range starting in row 11 to last used row in columns A, B and H of "NPSS_quote_sheet"
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'pastes the values in columns A, B and H in "Costing_tool"
                End If
            Next i
            With desWS
                'next 3 lines find the range that needs to be filled with G7, B7 and B6 of "NPSS_quote_sheet" in columns D, F and G in "Costing_tool"
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    'sorts data by 'Date' in "Costing_tool"
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With Application
        .CutCopyMode = False 'clears clipboard to unselect ranges copied for pasting
        .EnableEvents = True 'enables event macros
        .ScreenUpdating = True 'turns screen updating back on so you can see the changes made by the macro
    End With
End Sub

I am still learning to code in VBA so I don't fully understand this yet making it hard to debug.

I appreciate any help.

Thank,
Dave
 
Last edited:

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Have you stepped through using F8 to see what gets copied to the costing tool ??
Have you asked the author of the code why it gives this problem.
I'd need a copy of the workbook to play with it, as I don't really want to setup tables and sheets myself !
 
Upvote 0
Here is a copy of the spreadsheet, thanks Michael.

https://www.dropbox.com/s/jc05f9zxh50g1ip/quoting tool 7.9 WCI.xlsm?dl=0

I tried stepping through it and it seems to create the extra row in the middle line of code but I am not sure how to fix it.

Code: 
If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then 'Checks to see if there is more than one row of data and if so, executes next line
                    desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas
                End If
 
Upvote 0
I'm guessing the problem lies in the table itself in Costing_Tool, as you must have a Header and at least one row to be a table !!
When the data is copied across to costing_Tool it moves the initial row of that table down one row.
I'd suggest recording a small macro to odelete that row when finished and adding it in at the end of the larger code !
 
Upvote 0
I tried to adjust the code but it gives me an error of Object variable or with block variable not set.

Here is the code:

Code: 
Private Sub CmdSend_Click()
    Application.ScreenUpdating = False 'prevents screen flickering and speeds up the macro
    Application.EnableEvents = False 'prevents event macros from running which speeds up the macro and can avoid unwanted results or errors
    Dim desWS As Worksheet
    Dim srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet") 'source worksheet
        Set desWS = ThisWorkbook.Sheets("Costing_tool") 'destination worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim x As Long
    Dim sht As Worksheet
    Dim LastRow As Long
        sht = ActiveWorkbook.Worksheets("Costing_tool")
        LastRow = sht.ListObjects("tblCosting").Range.Rows.Count
    Dim header As Range 'defines 'header' as a range variable that will hold the header name found in "Costing_tool"
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row 'finds last used row in column B of "NPSS_quote_sheet"
        lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'finds last used row in column A of "Costing_tool"
    With srcWS.Range("A:A,B:B,H:H") 'columns to copy
        If lastRow2 < 5 Then 'checks if there is any data already copied in "Costing_tool" starting at row 5
            lastRow2 = 5 'if no data, sets last row to 5 and continues to next line of code, otherwise goes to 'Else' line of code
            For i = 1 To .Areas.Count 'loops through columns A, B and H
                x = .Areas(i).Column 'x represents the column number
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole) 'finds the header (row 10) in "Costing_tool"
                If Not header Is Nothing Then ' if found, executes next line of code
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy 'copies range starting in row 11 to lastrow in column
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'pastes value to corresponding column in "Costing_tool"
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then 'Checks to see if there is more than one row of data and if so, executes next line
                    desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas
                End If
                'next 3 lines find the range that needs to be filled with G7, B7 and B6 of "NPSS_quote_sheet" in columns D, F and G in "Costing_tool"
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else 'if data already existed, executes next line of code; see above for explanatory comments
            lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ''finds last used row in column A of "Costing_tool"
            desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas Can you explain this line of code with a comment please?
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole) 'finds the headers in columns A, B and H in row 4 columns A, B and H
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy 'Copies the range starting in row 11 to last used row in columns A, B and H of "NPSS_quote_sheet"
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'pastes the values in columns A, B and H in "Costing_tool"
                End If
            Next i
            With desWS
                'next 3 lines find the range that needs to be filled with G7, B7 and B6 of "NPSS_quote_sheet" in columns D, F and G in "Costing_tool"
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    'sorts data by 'Date' in "Costing_tool"
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Rows(LastRow).Select
    Selection.Delete Shift:=xlUp
    
    
    With Application
        .CutCopyMode = False 'clears clipboard to unselect ranges copied for pasting
        .EnableEvents = True 'enables event macros
        .ScreenUpdating = True 'turns screen updating back on so you can see the changes made by the macro
    End With
End Sub
 
Upvote 0
So what have you changed in the original code if it was working before ??
 
Upvote 0
I am not sure what I changed but I closed the file without saving it and now I have tried to write a little procedure to delete the last row on the sheet Cositng_tool which is the extra line that has been created but it is not working and I don't know why.

Here is the code:

Code: 
Sub cmdDeleteLastRow()
    
    Dim sht As Worksheet
    Dim LastRow As Long
    
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    
        LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            Rows(LastRow).Select
            Selection.Delete Shift:=xlUp
        
        
End Sub
 
Upvote 0
I tried to add Call cmdDeleteLastRow at the end of cmdSend and by itself, the macro deletes the extra line but when added into cmdSend, I get the error sub or function not defined.
 
Upvote 0
Replace you CmdSend_click() macro with this one

Code: 
Private Sub CmdSend_Click()
    Application.ScreenUpdating = False 'prevents screen flickering and speeds up the macro
    Application.EnableEvents = False 'prevents event macros from running which speeds up the macro and can avoid unwanted results or errors
    Dim desWS As Worksheet
    Dim srcWS As Worksheet
    Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet") 'source worksheet
    Set desWS = ThisWorkbook.Sheets("Costing_tool") 'destination worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim x As Long
    Dim header As Range 'defines 'header' as a range variable that will hold the header name found in "Costing_tool"
    lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row 'finds last used row in column B of "NPSS_quote_sheet"
    lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'finds last used row in column A of "Costing_tool"
    With srcWS.Range("A:A,B:B,H:H") 'columns to copy
        If lastRow2 < 5 Then 'checks if there is any data already copied in "Costing_tool" starting at row 5
            lastRow2 = 5 'if no data, sets last row to 5 and continues to next line of code, otherwise goes to 'Else' line of code
            For i = 1 To .Areas.Count 'loops through columns A, B and H
                x = .Areas(i).Column 'x represents the column number
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole) 'finds the header (row 10) in "Costing_tool"
                If Not header Is Nothing Then ' if found, executes next line of code
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy 'copies range starting in row 11 to lastrow in column
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'pastes value to corresponding column in "Costing_tool"
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then 'Checks to see if there is more than one row of data and if so, executes next line
                    desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas
                End If
                'next 3 lines find the range that needs to be filled with G7, B7 and B6 of "NPSS_quote_sheet" in columns D, F and G in "Costing_tool"
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else 'if data already existed, executes next line of code; see above for explanatory comments
            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row ''finds last used row in column A of "Costing_tool"
            desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas Can you explain this line of code with a comment please?
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole) 'finds the headers in columns A, B and H in row 4 columns A, B and H
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy 'Copies the range starting in row 11 to last used row in columns A, B and H of "NPSS_quote_sheet"
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'pastes the values in columns A, B and H in "Costing_tool"
                End If
            Next i
            With desWS
                'next 3 lines find the range that needs to be filled with G7, B7 and B6 of "NPSS_quote_sheet" in columns D, F and G in "Costing_tool"
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    'sorts data by 'Date' in "Costing_tool"
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Dim r As Long
    With Worksheets("Costing_tool").ListObjects("tblCosting").Range
        r = .Rows.Count
        .Rows(r).Delete
    End With
    With Application
        .CutCopyMode = False 'clears clipboard to unselect ranges copied for pasting
        .EnableEvents = True 'enables event macros
        .ScreenUpdating = True 'turns screen updating back on so you can see the changes made by the macro
    End With
End Sub
 
Upvote 0
Thanks for that Michael. I also found that the extra row is only put there the first time, or when there is no data already in tblCosting. If I have two rows in npss_quote and send them to the costing tool and there is nothing in the costing tool, it pastes the two rows into the costing tool so there is no extra rows. However, if I send the same 2 rows to the costing tool again, there becomes a total of 3 rows in the costing tool as it doesn't seem to create the extra row after there is data already in the costing tool. There should be 4 rows, (2 + 2) but one row gets deleted both times.

So, I think I need code that only allows the last row to be deleted once.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
681
mumps
mumps
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
667
myall_blues
myall_blues
W
  • Solved
Add a column w/ formula to copy / paste macro
Replies
5
Views
306
wknight7
W
S
  • Question Question
VBA to copy data from one worksheet to another (only specific columns)
Replies
2
Views
1K
SpireiteSteve
S
B
  • Question Question
Find Range of Rows to Delete using FIND
Replies
8
Views
120
Skyybot
Skyybot

Forum statistics

Threads
1,224,832
Messages
6,181,234
Members
453,026
Latest member
cknader

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