VBA to copy contents of a column for each row copied to a different column in destination sheet

[dpaton05]

I have tried to read and understand this code but I am having trouble. I need to know what to change in this code so the figure in column D on quote_sheet for each row is copied to column I for the row when it is copied to costing_tool. Could you also let me know what you have had to change/add?

Thanks

Sub cmdSend()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("quote_sheet")
        Set desWS = ThisWorkbook.Sheets("Costing_tool")
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, x As Long, header As Range
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
        lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        
    With srcWS.Range("A:A,B:B, G:G")
        If lastRow2 < 5 Then
            lastRow2 = 5
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
                    desWS.ListObjects.Item("tblCosting").ListRows.Add
                    .ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
                End If
                .Range("C" & lastRow2 & ":C" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("G4")
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B5")
                .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
            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            desWS.ListObjects.Item("tblCosting").ListRows.Add
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                .Range("C" & lastRow2 + 1 & ":C" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G4")
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B5")
                .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
    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
    
    Call AddName
    
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Dim oLst As ListObject
        Dim lr As Long, rng As Range
        lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lr To 4 Step -1
            Set rng = desWS.Cells(i, 1)
            If WorksheetFunction.CountBlank(rng) = 1 Then
                desWS.Rows(i).Delete
            End If
        Next i
End Sub

 

[hernantorres23]

Hi, If you can, give another example, explaining what data you have, what conditions they meet, what they should add and what result you expect.

In addition, the code, use a function that you haven't in your post

Please try prepare a data example using add-in specifically for this and it can be found here XL2BB
Pay attention to this post XL2BB 2 Squares