VBA code - Copy pasting cells from sheet1 to sheet2

J

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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Do you mean something like this?

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")
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied
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 Errhand
    
Debug.Print Timer() - coT
Errhand:
    Call TurnOnFeatures
End Sub

Public Function TurnOffFeatures()
Application.Calculation = xlManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
End Function
Public Function TurnOnFeatures()
Application.Calculation = xlAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Function
 
Upvote 0
Tupe77 said:
Do you mean something like this?

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")
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied
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 Errhand
   
Debug.Print Timer() - coT
Errhand:
    Call TurnOnFeatures
End Sub

Public Function TurnOffFeatures()
Application.Calculation = xlManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
End Function
Public Function TurnOnFeatures()
Application.Calculation = xlAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Function
Click to expand...
Hi Tupe77,
Thank you and this really works well when it comes to copy paste the information from one sheet to another.
On the Cleansed data sheet where the data is getting copied I have some challenges with formatting:
Column D3 to D5000, need to copy paste in a way which should not reflect as wrap text
Column G3 to G5000, to reflect with formula = E3*F3, E4*F4, so on and so forth upto cell G5000
Column H to be formatted with "short date" format
Finally, to copy cell A5000 value and replicate in all the cells from A3:A5000
Can you please help me one more time.

Thank you!
 
Upvote 0
I'm not sure I understood all your requests correctly, but
here is some kind of quick fix according to your requests.



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")
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied
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 Errhand
   
' New part   
Worksheets("Cleansed data").Range("H2:H5000").NumberFormat = "yyyy-mm-dd"
Worksheets("Cleansed data").Range("A3:A5000").Value2 = Worksheets("Cleansed data").Range("A5000").Value2
Worksheets("Cleansed data").Range("G3").Formula = "=E3*F3"
Worksheets("Cleansed data").Range("G3:G5000").FillDown
Worksheets("Cleansed data").Range("C3:C5000").WrapText = False
' New part end
    
Debug.Print Timer() - coT
Errhand:
    Call TurnOnFeatures
End Sub

Public Function TurnOffFeatures()
Application.Calculation = xlManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
End Function
Public Function TurnOnFeatures()
Application.Calculation = xlAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Function



My apologies for any quirks, English is not my native language.
 
Upvote 0
Solution
Tupe77 said:
I'm not sure I understood all your requests correctly, but
here is some kind of quick fix according to your requests.



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")
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied
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 Errhand
  
' New part  
Worksheets("Cleansed data").Range("H2:H5000").NumberFormat = "yyyy-mm-dd"
Worksheets("Cleansed data").Range("A3:A5000").Value2 = Worksheets("Cleansed data").Range("A5000").Value2
Worksheets("Cleansed data").Range("G3").Formula = "=E3*F3"
Worksheets("Cleansed data").Range("G3:G5000").FillDown
Worksheets("Cleansed data").Range("C3:C5000").WrapText = False
' New part end
   
Debug.Print Timer() - coT
Errhand:
    Call TurnOnFeatures
End Sub

Public Function TurnOffFeatures()
Application.Calculation = xlManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
End Function
Public Function TurnOnFeatures()
Application.Calculation = xlAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Function



My apologies for any quirks, English is not my native language.
Click to expand...
Thank Tupe77 for addressing the challenges and concern. All is good and it works perfectly well as expected
 
Upvote 0
Thank you for the feedback!
It's nice to hear that we were able to help.
 
Upvote 0
J S A said:
Thank Tupe77 for addressing the challenges and concern. All is good and it works perfectly well as expected
Click to expand...
Tupe77, is it possible if i now copy + paste your VBA script into the working file with no changes to the "Sheet name", it can create a challenge?
Just to let you know, the working file also has some other small VBA scripts linked to other sheets
 
Upvote 0
Tupe77, is it possible if i now copy + paste your VBA script into the working file with no changes to the "Sheet name", it can create a challenge?
Just to let you know, the working file also has some other small VBA scripts linked to other sheets
Tupe77 said:
Thank you for the feedback!
It's nice to hear that we were able to help.
Click to expand...
 
Upvote 0
"if i now copy + paste your VBA script into the working file"

TS_CopyColByOrder_headers2row uses the source and destination worksheet names, so they must be correct:
VBA Code: 
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied


The name of the workbook has not been defined, so the worksheets must be found in the same workbook where from TS_CopyColByOrder_headers2row is executed.
Basically, other scripts should have no effect on this. The exception may be some events.

Did this answer your question?
 
Upvote 0
a
Tupe77 said:
"if i now copy + paste your VBA script into the working file"

TS_CopyColByOrder_headers2row uses the source and destination worksheet names, so they must be correct:
VBA Code: 
Dim wsSOURCE As Worksheet: Set wsSOURCE = Worksheets("PO lines data")                                                       ' The source Sheet of the data to be copied
Dim wsDESTINATION As Worksheet: Set wsDESTINATION = Worksheets("Cleansed data")                                             ' the destination sheet to which the data is copied


The name of the workbook has not been defined, so the worksheets must be found in the same workbook where from TS_CopyColByOrder_headers2row is executed.
Basically, other scripts should have no effect on this. The exception may be some events.

Did this answer your question?
Click to expand...
Even I thought it shouldnt have any effect. Now wondering what its causing to not fetch the data from source to destination sheet.
Many thanks for the help though! Much appreciated
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question
VBA Import columns by headers - Need prompts to select workbook/sheet name
Replies
2
Views
204
floggingmolly
F
U
  • Solved
Copying specific columns from worksheet to worksheet, error 1004
Replies
5
Views
383
ufka1
U
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
241
B-radK
B
P
  • Question
Code used for comparison between 2 list.
Replies
3
Views
323
Tupe77
T
C
  • Question
Named ranges from multiple sections of cells copy paste not working
Replies
6
Views
116
Alex Blakenburg
A

Forum statistics

Threads
1,215,191
Messages
6,123,553
Members
449,108
Latest member
rache47

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