Table headers being replaced when copying to it from another table

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
1,025
I have some vba code that copies rows from a table to another table on another sheet.

The headers for columns D, F and G on the destination table keep being replaced with column1, column 2 and column 3, instead of being left the as they are.
I can't see where it is doing it in the code. Could someone please help me?


Code:
[FONT=&quot]Sub cmdSendNP()[/FONT]

  [FONT=&quot]    Application.ScreenUpdating = False[/FONT]
  [FONT=&quot]    Application.EnableEvents = False[/FONT]
  [FONT=&quot]    Dim desWS As Worksheet, srcWS As Worksheet[/FONT]
  [FONT=&quot]        Set srcWS = ThisWorkbook.Sheets("CSS_quote_sheet")[/FONT]
  [FONT=&quot]        Set desWS = ThisWorkbook.Sheets("Costing_tool")[/FONT]
  [FONT=&quot]    Dim lastRow1 As Long, lastRow2 As Long[/FONT]
  [FONT=&quot]    Dim i As Long, x As Long, header As Range[/FONT]
  [FONT=&quot]        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row[/FONT]
  [FONT=&quot]        lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row[/FONT]
  [FONT=&quot]    With srcWS.Range("A:A,B:B,G:G")[/FONT]
  [FONT=&quot]        If lastRow2 < 5 Then[/FONT]
  [FONT=&quot]            lastRow2 = 5[/FONT]
  [FONT=&quot]            For i = 1 To .Areas.Count[/FONT]
  [FONT=&quot]                x = .Areas(i).Column[/FONT]
  [FONT=&quot]                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)[/FONT]
  [FONT=&quot]                If Not header Is Nothing Then[/FONT]
  [FONT=&quot]                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy[/FONT]
  [FONT=&quot]                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues[/FONT]
  [FONT=&quot]                End If[/FONT]
  [FONT=&quot]            Next i[/FONT]
  [FONT=&quot]            With desWS[/FONT]
  [FONT=&quot]                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then[/FONT]
  [FONT=&quot]                    .ListObjects.Item("tblCosting").ListRows.Add[/FONT]
  [FONT=&quot]                    .ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"[/FONT]
  [FONT=&quot]                End If[/FONT]
  [FONT=&quot]                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B5")[/FONT]
  [FONT=&quot]                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B7")[/FONT]
  [FONT=&quot]                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B6")[/FONT]
  [FONT=&quot]            End With[/FONT]
  [FONT=&quot]        Else[/FONT]
  [FONT=&quot]            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row[/FONT]
  [FONT=&quot]            desWS.ListObjects.Item("tblCosting").ListRows.Add[/FONT]
  [FONT=&quot]            For i = 1 To .Areas.Count[/FONT]
  [FONT=&quot]                x = .Areas(i).Column[/FONT]
  [FONT=&quot]                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)[/FONT]
  [FONT=&quot]                If Not header Is Nothing Then[/FONT]
  [FONT=&quot]                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy[/FONT]
  [FONT=&quot]                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues[/FONT]
  [FONT=&quot]                End If[/FONT]
  [FONT=&quot]            Next i[/FONT]
  [FONT=&quot]            With desWS[/FONT]
  [FONT=&quot]                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B5")[/FONT]
  [FONT=&quot]                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")[/FONT]
  [FONT=&quot]                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")[/FONT]
  [FONT=&quot]            End With[/FONT]
  [FONT=&quot]        End If[/FONT]
  [FONT=&quot]    End With[/FONT]
  [FONT=&quot]    desWS.ListObjects("tblCosting").Sort.SortFields.Clear[/FONT]
  [FONT=&quot]    desWS.ListObjects("tblCosting").Sort.SortFields. _[/FONT]
  [FONT=&quot]        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _[/FONT]

  [FONT=&quot]        xlAscending, DataOption:=xlSortNormal[/FONT]
  [FONT=&quot]    With desWS.ListObjects("tblCosting").Sort[/FONT]
  [FONT=&quot]        .header = xlYes[/FONT]
  [FONT=&quot]        .MatchCase = False[/FONT]
  [FONT=&quot]        .Orientation = xlTopToBottom[/FONT]
  [FONT=&quot]        .SortMethod = xlPinYin[/FONT]
  [FONT=&quot]        .Apply[/FONT]
  [FONT=&quot]    End With[/FONT]
  [FONT=&quot]    [/FONT]
  [FONT=&quot]    Call AddNameNP[/FONT]
  [FONT=&quot]    [/FONT]
  [FONT=&quot]    With Application[/FONT]
  [FONT=&quot]        .CutCopyMode = False[/FONT]
  [FONT=&quot]        .EnableEvents = True[/FONT]
  [FONT=&quot]        .ScreenUpdating = True[/FONT]
  [FONT=&quot]    End With[/FONT]
  [FONT=&quot]    Dim oLst As ListObject[/FONT]
  [FONT=&quot]        Dim lr As Long, rng As Range[/FONT]
  [FONT=&quot]        lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row[/FONT]
  [FONT=&quot]        For i = lr To 4 Step -1[/FONT]
  [FONT=&quot]            Set rng = desWS.Cells(i, 1)[/FONT]
  [FONT=&quot]            If WorksheetFunction.CountBlank(rng) = 1 Then[/FONT]
  [FONT=&quot]                desWS.Rows(i).Delete[/FONT]
  [FONT=&quot]            End If[/FONT]
  [FONT=&quot]        Next i[/FONT]
  [FONT=&quot]End Sub[/FONT]
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
17,957
Office Version
2013
Platform
Windows
maybe here....change 4 to 5 !!
Have you tried stepping through the code to see which line / s remove the headings

Code:
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
 
Last edited:

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
1,025
I think I might have found it but I am not sure how to fix it

Code:
Sub cmdSendNP()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("CSS_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
                    .ListObjects.Item("tblCosting").ListRows.Add
                    .ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
                End If
                .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")
When it gets to running the last 3 lines of code is when the headers in columns D, F and G get replaced with column 1, 2 and 3. What is wrong with this code?
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
1,025
I tried your solution in post 3 Michael and it didn't work.
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
17,957
Office Version
2013
Platform
Windows
So the last 3 lines of code will run, regardless of how many lines are in tblCosting.
Is that what you want to happen ??
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
1,025
There is some information such as name, organisation, etc in cells B5, B6, B7 and G4. The table starts in row 11 and each entry in the table relates to the info entered in the cells above. Therefore, on the costing_tool sheet, each row from the table on the quote_sheet needs to be copied to tblCosting but every for each row, the information in cells B5, B6, B7 and G4 needs to be entered in the column in tblCosting as follows:
  • B5 to column D
  • B6 to column G
  • B7 to column F
  • G4 to column C
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
1,025
Just realised, I try and run the code and nothing will be copied between the 2 tables. The information held in the cells above the table on quote_sheet (B5, B6, B7 and G4) do not get put into each row that is copied from table on quote_sheet to tblCosting, regardless of how many rows are in table on the quote_sheet, those rows instead replace the headers on tblCosting. Even if there are multiple rows to copy on table on the quote_sheet, new rows are not made with the information in those cells being pasted in.

How do I get the data stored in these cells to be entered into the appropriate columns for each new row that is copied between the tables?

Here is the code I am using:

VBA Code:
Sub SendCode()
    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")
                .Range("D4").Value = "Child name"
                .Range("F4").Value = "Requesting Organisation"
                .Range("G4").Value = "Caseworker name"
            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
    
    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 5 Step -1
            Set rng = desWS.Cells(i, 1)
            If WorksheetFunction.CountBlank(rng) = 1 Then
                desWS.Rows(i).Delete
            End If
        Next i
End Sub
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
17,957
Office Version
2013
Platform
Windows
First question, have you tried it in an earlier version ??
AND
Will the code run in V19.2 of the quoting tool ?
I'm away all week so may not get a chance to have a look.
 

Forum statistics

Threads
1,077,686
Messages
5,335,657
Members
399,032
Latest member
thefinu

Some videos you may like

This Week's Hot Topics

Top