VBA code to copy in a mirror image

[dpaton05]

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?

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

 

[Michael M]

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 !

 

[dpaton05]

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.

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

 

[Michael M]

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 !

 

[dpaton05]

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:

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

 

[Michael M]

So what have you changed in the original code if it was working before ??

 

[dpaton05]

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:

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

 

[dpaton05]

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.

 

[Michael M]

Replace you CmdSend_click() macro with this one

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

 

[dpaton05]

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.