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

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
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

C
  • Solved
Copy paste columns based on matching header into another workbook
Replies
5
Views
325
mumps
mumps
F
  • Question Question
VBA Import columns by headers - Need prompts to select workbook/sheet name
Replies
2
Views
371
floggingmolly
F
U
  • Solved
Copying specific columns from worksheet to worksheet, error 1004
Replies
5
Views
516
ufka1
U
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
667
myall_blues
myall_blues
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
357
Logit
Logit

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

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