VBA code - Copy pasting cells from sheet1 to sheet2

J S A

New Member
Joined
Mar 7, 2023
Messages
14
Office Version
  1. 365
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
 
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?
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
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

VBA Code:
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
 
Upvote 0
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

VBA Code:
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.
 
Upvote 0
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:
VBA Code:
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

With:
VBA Code:
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary"):Dict.CompareMode = TextCompare
 
Upvote 0
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:
VBA Code:
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

With:
VBA Code:
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary"):Dict.CompareMode = TextCompare
This time it showing an error as attached
 

Attachments

  • Error.JPG
    Error.JPG
    186.8 KB · Views: 8
Upvote 0
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:
VBA Code:
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")

With:
VBA Code:
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"
 
Upvote 0
i carried Hlookup formula against the headers (Cleansed Data) and the data is matching with the header level information in the (PO lines Data)
 

Attachments

  • hlookup outcome.JPG
    hlookup outcome.JPG
    114.8 KB · Views: 8
Upvote 0
Did you change the line that starts with "Dim Dict As Object:" It might matter when comparing titles.
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

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