Table headers being replaced when copying to it from another table

D

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,373
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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]
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
The destination table starts in row5 with the header in row 4
 
Upvote 0
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:
Upvote 0
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?
 
Upvote 0
I tried your solution in post 3 Michael and it didn't work.
 
Upvote 0
So the last 3 lines of code will run, regardless of how many lines are in tblCosting.
Is that what you want to happen ??
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Forgot to say please can you help me with this Michael.
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA to copy data from one worksheet to another (only specific columns)
Replies
2
Views
1K
SpireiteSteve
S
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
608
myall_blues
myall_blues
N
  • Question Question
AutoFilter Field Macro Returns a Header Row only
2
Replies
11
Views
94
MARK858
MARK858
N
  • Question Question
My code is suddenly really slow
Replies
1
Views
359
RobP
R
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
286
mumps
mumps

Forum statistics

Threads
1,223,703
Messages
6,173,973
Members
452,540
Latest member
haasro02

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