VBA code - Copy pasting cells from sheet1 to sheet2

[J S A]

Hi, Need your help. I am learning to write some VBA code with criteria matching the header required to bring the data from one sheet to another.
Below is the code which runs successfully to an extent where the vba fails to bring the last row cell from the respective column and thereby failing the loop too.

Dim head_count As Integer
Dim row_count As Integer
Dim col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = ThisWorkbook.Sheets("PO lines data")
Set ws2 = ThisWorkbook.Sheets("Cleansed data")

ws2.Activate
head_count = WorksheetFunction.CountA(Range("A2", Range("A2").End(xlToRight)))

ws1.Activate
col_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
row_count = WorksheetFunction.CountA(Range("A2", Range("A2").End(xlDown)))

For i = 2 To head_count

j = 1

Do While j <= col_count

If ws2.Cells(2, i) = ws1.Cells(1, j).Text Then

ws1.Range(Cells(1, j), Cells(row_count, j)).copy
ws2.Cells(2, i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
j = col_count

End If

j = j + 1

Loop

Next i

 

[Tupe77]

1. It worked correctly in the first (test) workbook?
2. When copied to another workbook it doesn't work?
2.1 "to not fetch the data from source to destination sheet" means that nothing is copied to the destination sheet?

 

[Tupe77]

No fixes here, but removed error handling so debug shows errors.
Added three Debug.Print entries.
1. Workbook
2. Source sheet workbook
2.1 Name of the source sheet
3. Destination sheet workbook
3.1 Destination sheet name

The workbook must be the same in points 1, 2, 3

Sub TS_CopyColByOrder_headers2row()
'On Error GoTo Errhand: Call TurnOffFeatures: Dim coT As Single: coT = Timer()
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
Debug.Print "1. ThisWorkbook.Name: " & ThisWorkbook.Name
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Debug.Print "2. wsSOURCE.parent.name: " & wsSOURCE.Parent.Name & vbNewLine & "2.1 wsSOURCE.Name: " & wsSOURCE.Name
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied
Debug.Print "3. wsDESTINATION.parent.name: " & wsDESTINATION.Parent.Name & vbNewLine & "3.1 wsDESTINATION.Name: " & wsDESTINATION.Name
Dim AllDataRNG As Range: Set AllDataRNG = wsSOURCE.Range("A1").CurrentRegion                                                ' (A1) The cell that belongs range of the source data headers
Dim DestinationHeadersRNG As Range: Set DestinationHeadersRNG = wsDESTINATION.Range("A2").CurrentRegion.Rows(1)             ' (A2) The cell that belongs range of the destination data headers
Dim SourceHeadersRNG As Range: Set SourceHeadersRNG = AllDataRNG.Rows(1)
Dim DataRNG As Range: Set DataRNG = AllDataRNG.Resize(AllDataRNG.Rows.Count - 1, AllDataRNG.Columns.Count).Offset(1, 0)
Dim TmpRNG As Range, TmpVAR As Variant
Dim LastRowLNG As Long: LastRowLNG = 1

    For Each TmpRNG In SourceHeadersRNG.Cells
        Dict(TmpRNG.Value2) = DataRNG.Columns(TmpRNG.Column).Value2
    Next TmpRNG
    
    On Error Resume Next
        For Each TmpRNG In DestinationHeadersRNG.Cells
            TmpVAR = TmpRNG.Value2
            TmpRNG.Offset(LastRowLNG, 0).Resize(UBound(Dict(TmpVAR)), 1).Value2 = Dict(TmpVAR)
        Next TmpRNG
    On Error GoTo -1
    'On Error GoTo Errhand
    
' Removed sheet names from hotfixes and replaced them with wsDESTINATION. So that worksheet names need only defined with the wsDESTINATION and wsSOURCE variables.
wsDESTINATION.Range("H2:H5000").NumberFormat = "yyyy-mm-dd"
wsDESTINATION.Range("A3:A5000").Value2 = wsDESTINATION.Range("A5000").Value2
wsDESTINATION.Range("G3").Formula = "=E3*F3": wsDESTINATION.Range("G3:G5000").FillDown
wsDESTINATION.Range("C3:C5000").WrapText = False
    
'Errhand:
    'Call TurnOnFeatures:Debug.Print Timer() - coT
End Sub

 

[J S A]

No fixes here, but removed error handling so debug shows errors.
Added three Debug.Print entries.
1. Workbook
2. Source sheet workbook
2.1 Name of the source sheet
3. Destination sheet workbook
3.1 Destination sheet name

The workbook must be the same in points 1, 2, 3

Sub TS_CopyColByOrder_headers2row()
'On Error GoTo Errhand: Call TurnOffFeatures: Dim coT As Single: coT = Timer()
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
Debug.Print "1. ThisWorkbook.Name: " & ThisWorkbook.Name
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Debug.Print "2. wsSOURCE.parent.name: " & wsSOURCE.Parent.Name & vbNewLine & "2.1 wsSOURCE.Name: " & wsSOURCE.Name
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied
Debug.Print "3. wsDESTINATION.parent.name: " & wsDESTINATION.Parent.Name & vbNewLine & "3.1 wsDESTINATION.Name: " & wsDESTINATION.Name
Dim AllDataRNG As Range: Set AllDataRNG = wsSOURCE.Range("A1").CurrentRegion                                                ' (A1) The cell that belongs range of the source data headers
Dim DestinationHeadersRNG As Range: Set DestinationHeadersRNG = wsDESTINATION.Range("A2").CurrentRegion.Rows(1)             ' (A2) The cell that belongs range of the destination data headers
Dim SourceHeadersRNG As Range: Set SourceHeadersRNG = AllDataRNG.Rows(1)
Dim DataRNG As Range: Set DataRNG = AllDataRNG.Resize(AllDataRNG.Rows.Count - 1, AllDataRNG.Columns.Count).Offset(1, 0)
Dim TmpRNG As Range, TmpVAR As Variant
Dim LastRowLNG As Long: LastRowLNG = 1

    For Each TmpRNG In SourceHeadersRNG.Cells
        Dict(TmpRNG.Value2) = DataRNG.Columns(TmpRNG.Column).Value2
    Next TmpRNG
   
    On Error Resume Next
        For Each TmpRNG In DestinationHeadersRNG.Cells
            TmpVAR = TmpRNG.Value2
            TmpRNG.Offset(LastRowLNG, 0).Resize(UBound(Dict(TmpVAR)), 1).Value2 = Dict(TmpVAR)
        Next TmpRNG
    On Error GoTo -1
    'On Error GoTo Errhand
   
' Removed sheet names from hotfixes and replaced them with wsDESTINATION. So that worksheet names need only defined with the wsDESTINATION and wsSOURCE variables.
wsDESTINATION.Range("H2:H5000").NumberFormat = "yyyy-mm-dd"
wsDESTINATION.Range("A3:A5000").Value2 = wsDESTINATION.Range("A5000").Value2
wsDESTINATION.Range("G3").Formula = "=E3*F3": wsDESTINATION.Range("G3:G5000").FillDown
wsDESTINATION.Range("C3:C5000").WrapText = False
   
'Errhand:
    'Call TurnOnFeatures:Debug.Print Timer() - coT
End Sub

Thank you for going extra mile for trying to fix this. I copied the entire VBA script as it is in my working file and what i see couple of things:
1. The data is not getting copy pasted from PO lines data sheet
2. The VBA script is running till the end as it is running below script which appears only in the end
wsDESTINATION.Range("G3").Formula = "=E3*F3": wsDESTINATION.Range("G3:G5000").FillDown

However, if i add this script to completely new workbook and giving the same sheet names; it works efficiently without any showstopper.

 

[Tupe77]

I suspect that there is some difference in the headers and they are not recognized as similar.

This changes the comparison from binary to text comparison. It may help.

Replace:

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

With:

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary"):Dict.CompareMode = TextCompare

 

[J S A]

I suspect that there is some difference in the headers and they are not recognized as similar.

This changes the comparison from binary to text comparison. It may help.

Replace:

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

With:

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary"):Dict.CompareMode = TextCompare

This time it showing an error as attached

 

[J S A]

it

I suspect that there is some difference in the headers and they are not recognized as similar.

This changes the comparison from binary to text comparison. It may help.

Replace:

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

With:

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary"):Dict.CompareMode = TextCompare

Is it possible the text that is being compared is duplicated and it is not looking for absolute reference
For Ex:
Cleansed Data sheet has C3 cell reference as "Part No"
In PO lines data sheet there are multiple references - "Part no", "Supplier's Part no", and "Manufacturer's Part No"

 

[J S A]

i carried Hlookup formula against the headers (Cleansed Data) and the data is matching with the header level information in the (PO lines Data)

 

[Tupe77]

Did you change the line that starts with "Dim Dict As Object:" It might matter when comparing titles.

 

[J S A]

Did you change the line that starts with "Dim Dict As Object:" It might matter when comparing titles.

Yes i changed it as you mentioned in your last thread and which reads as below :

Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary"): Dict.CompareMode = TextCompare

 

[Tupe77]

I was hoping that would be it. I'm using my cell phone to this conversation, so I can't do better now, without a computer. Can you upload your workbook or worksheets and vba here with a few lines of dump example data?