VBA code to copy in a mirror image

D

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,352
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:
Sort by date Sort by votes
Ok, replace CmdSend_click()

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 oLst As ListObject
'----------------------------------------------------------
'''''''deletes last row in tblCosting if it is a blank row
If desWS.ListObjects.Count > 0 Then
    For Each oLst In desWS.ListObjects
        If oLst.ListRows.Count > 0 Then
          oLst.ListRows(oLst.ListRows.Count).Delete
        End If
    Next oLst
End If
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

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Thanks Michael. That code seems to do the same thing as the previous code. The first time you copy some rows it seems to work correctly but then every subsequent time after that it copies the rows in the npss_quote but it deletes a row.
 
Upvote 0
Another crack

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
 
Upvote 0
I simply commented these lines out.....

Code: 
If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
     desWS.ListObjects.Item("tblCosting").ListRows.Add 'inserts blank row with formulas
End If
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA to copy data from one worksheet to another (only specific columns)
Replies
2
Views
762
SpireiteSteve
S
A
  • Question
how to add my signature with images to macro
Replies
1
Views
172
Domenic
D
J
  • Locked
  • Question
Help with code to copy value if criteria is met
Replies
1
Views
132
Fluff
Fluff
N
  • Question
My code is suddenly really slow
Replies
1
Views
136
RobP
R
H
  • Solved
problem with code- removing duplicate rows
Replies
2
Views
143
heathball
H

Forum statistics

Threads
1,215,032
Messages
6,122,772
Members
449,095
Latest member
m_smith_solihull

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