Copy data criteria is Rowheaders, but does not copy corectly

[Sjon1974]

I am found this script to copy data from sheet a to sheet b
But when i use it instead of copying the data in every column next to each other, it follows the last row of the column before this column.

Roweheader	Rowheader	roweheader
Value A	Value b should be here	value c should be here
	Value B
		Value C

Can somebody check the code and explain this to me?

Sub import()
Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Import")
Set ws_B = wb.Worksheets("Database")
Set NameList_A = CreateObject("Scripting.Dictionary")

With ws_A
    SourceDataStart = 2
    HeaderRow_A = 1  'set the header row in sheet A
    TableColStart_A = 1 'Set start col in sheet A
    HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column  'Get number of NAMEs you have

    For i = TableColStart_A To HeaderLastColumn_A
        If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then  'check if the name exists in the dictionary
             NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
        End If
    Next i

End With




With ws_B  'worksheet you want to paste data into
    ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
    For i = 1 To ws_B_lastCol   'for each data
        SourceCol_A = NameList_A(UCase(.Cells(1, i).Value))  'get the column where the name is in Sheet A from the dictionaary

        If SourceCol_A <> 0 Then  'if 0 means the name doesnt exists
            SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
            Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
            NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A

            .Range(.Cells(NextEntryline, i), _
                   .Cells(NextEntryline, i)) _
                   .Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
        End If

    Next i
End With
ActiveWorkbook.RefreshAll
Call TBL1
End Sub

 

[Caleeco]

Hi,

This seems like an awful lot of code for a copy/paste. What specifically do you need to do?

It looks like the code is doing some sort of check for unique values and the copying across. Is this what you want?

Cheers
Caleeco

 

[Sjon1974]

Hi,

This seems like an awful lot of code for a copy/paste. What specifically do you need to do?

It looks like the code is doing some sort of check for unique values and the copying across. Is this what you want?

Cheers
Caleeco

Cause of the changing amount of columns per period, i need to copy data in the database based of the rowheader which are always the same in both sheets.

So it is looking for the rowheader if it is equal then copy the data to the correct column. with that i prefend that when i copy the data could be in a wrong column in sheet B cause the new download is different in column numbers

 

[Caleeco]

Ok I think I get what you want to do. Some filler questions

1. Are the headers both one Row 1 of each sheet?
2. Is the sheet being copied TO having data added to it? or is it overwriting data starting in row 2

Cheers
Caleeco

 

[Sjon1974]

It is in both sheets in row 1 starting in cell A

And it is data adding

 

[Caleeco]

Thanks,

Also, will all data be copied to the same row (on the sheet being added to) or do we need to find the last row of each individual column being added to?

Cheers
Caleeco

 

[Sjon1974]

all the data being copied to the same row, where column a is leading i think. Itis the first column where it is checking

 

[Caleeco]

Thanks for the carification. I've written some code, which is working on my small sample dataset.

Can you test on your end and see if the desired result is achieved?

Sub Copy_Data()
    Dim wb          As Workbook
    Dim ws_A        As Worksheet
    Dim ws_B        As Worksheet
    Dim CopyToRow   As Long
    Dim CopyToCol   As Long
    Dim LastColumnA As Long
    Dim LastColumnB As Long
    Dim i           As Long
    Dim HDR         As String
    Dim rFind       As Range
    
    Set wb = ActiveWorkbook
    Set ws_A = wb.Worksheets("Import")
    Set ws_B = wb.Worksheets("Database")
    
    Application.ScreenUpdating = False
    
    LastColumnA = ws_A.Cells(1, ws_A.Columns.Count).End(xlToLeft).Column
    LastColumnB = ws_B.Cells(1, ws_B.Columns.Count).End(xlToLeft).Column
    CopyToRow = ws_B.Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 1 To LastColumnA
        HDR = ws_A.Cells(1, i)
        ws_B.Activate
        Set rFind = ws_B.Range(Cells(1, 1), Cells(1, LastColumnB)).Find(What:=HDR, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
         If Not rFind Is Nothing Then
            CopyToCol = rFind.Column
            ws_A.Activate
            ws_A.Range(Cells(2, i), Cells(2, i).End(xlDown)).Copy
            ws_B.Cells(CopyToRow, CopyToCol).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

Cheers
Caleeco

 

[Sjon1974]

It is stopping in the Set rFind with a 1004 error

if i hover over it i find this

 

[Caleeco]

Hmm strange.. code works on my sheet. Is your sheet name "Database" (the one being copied to).

Cheers
Caleeco