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

 

[Sjon1974]

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

Cheers
Caleeco

Yes ws_B is "Database"

 

[Caleeco]

Ok, could you try chaging that line that is erroring to:

Set rFind = ws_B.Range(Cells(1, 1).Address, Cells(1, LastColumnB).Address).Find(What:=HDR, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)

And re-test

Cheers
Caleeco

 

[Sjon1974]

Ok, could you try chaging that line that is erroring to:

Set rFind = ws_B.Range(Cells(1, 1).Address, Cells(1, LastColumnB).Address).Find(What:=HDR, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)

And re-test

Cheers
Caleeco

Okay, we are getting closer, no we have a runtime error 1004 in the line

ws_A.Range(Cells(2, i), Cells(2, i).End(xlDown)).Copy

 

[Caleeco]

Might be something to do with Excel 365... (i have 2010!). Try adding address references here also

ws_A.Range(Cells(2, i).Address, Cells(2, i).End(xlDown).Address).Copy

 

[Sjon1974]

Might be something to do with Excel 365... (i have 2010!). Try adding address references here also

ws_A.Range(Cells(2, i).Address, Cells(2, i).End(xlDown).Address).Copy

Hmm one step further, i do not understand why if you have a different office it is not working

ws_B.Cells(CopyToRow, CopyToCol).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

 

[Caleeco]

Im not sure, but we upgraded to 365 at work and many VBA spreadsheets stopped functioning correctly

Based on that error, can you see if this works?

         If Not rFind Is Nothing Then
            CopyToCol = rFind.Column
            ws_A.Activate
            ws_A.Range(Cells(2, i).Address, Cells(2, i).End(xlDown).Address).Copy
            ws_B.Cells(CopyToRow, CopyToCol).Select
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        End If

Cheers,
Caleeco

 

[Sjon1974]

I just did some grazy with the old code, and i removed the "database" and placed a new sheet with the same data copied but as values and now it is pasting it correct.

Could it be that with your script that would be a problem also?