Formatting Data from One to To Format on Another

[psulions83]

Hi,

I have a worksheet with columns in order I need data. On a second tab I have data that I want to convert to the same order as the first tab. I had an hlookup funtion that worked but when trying to do this for thousands of rows it would not finish. Is there a more efficient way to do this that anyone can suggest?

 

[psulions83]

Joe,

This works awesome. Thank you very much for this!!

 

[Joe4]

You are welcome!

 

[psulions83]

Joe, is it possible to add one more piece to this?

My thought is I would have 4 tab with CURRENT headers. So CURRENT - 1, CURRENT - 2, CURRENT - 3, CURRENT - 4. Then on a new tab I would have a button along with a drop down where you can choose which tab you want to run for. The PRIOR tab would always just be whatever you want the macro to run for.

So would follow this:
1. Pick from drop down
2. Press button to run macro
3. Copy from prior to whatever was chosen in step 1.

I have done this before with a spec sheet but that was in access.

 

[Joe4]

Would you want to do it that way, or simply have the macro ask them to type in the name of the sheet that they want it to copy to?

 

[psulions83]

I think typing would be good then the drop down wouldnt need to be maintained if anything more is added

 

[Joe4]

Try this variation:

Sub MyCopy()

    Dim dst As String
    Dim pws As Worksheet, cws As Worksheet
    Dim lc As Long, c As Long, nc As Long
    Dim lr As Long
    Dim hdr As Variant
    
'   Set prior worksheet object
    Set pws = Sheets("Prior")
    
'   Prompt them to enter name of sheet to copy to and see if it exists
    dst = InputBox("Enter the exact name of current sheet you want to paste to")
    On Error GoTo no_sheet
    Set cws = Sheets(dst)
    On Error GoTo 0
    
    Application.ScreenUpdating = False
    
'   Find last column with data in row 1 of prior ws
    lc = pws.Cells(1, Columns.Count).End(xlToLeft).Column
    
'   Find last row with data on prior ws
    lr = pws.Range("A1").SpecialCells(xlLastCell).Row
    
    pws.Activate
'   Loop through all columns on prior ws
    For c = 1 To lc
'       Get column header from prior ws
        hdr = pws.Cells(1, c)
'       Find which column hdr is found on current ws
        On Error GoTo err_chk
        nc = cws.Rows("1:1").Find(hdr, LookIn:=xlValues, LookAt:=xlWhole).Column
        On Error GoTo 0
'       Copy data if value found
        If nc > 0 Then
            pws.Range(Cells(2, c), Cells(lr, c)).Copy cws.Cells(2, nc)
        Else
'           Message if cannot find column
            MsgBox "Cannot find matching header " & hdr & " on Current sheet", vbOKOnly
        End If
    Next c
    
    Application.ScreenUpdating = True
    
    MsgBox "Copy complete!", vbOKOnly
        
    Exit Sub
    
    
'   Error if no sheet exits
no_sheet:
    MsgBox "No sheet with name " & dst & " exists!", vbOKOnly, "ERROR!"
    Exit Sub
    
    
'   Error handling if cannot find column
err_chk:
    nc = 0
    Err.Clear
    Resume Next
    
End Sub

 

[psulions83]

Joe, works great! Thank you very much for all the help.

 

[Joe4]

You are welcome.