Macro or VBA to copy and fill data to a new sheet, different format.

[datavizwiz]

Hi!

I'm really hoping someone here can help me. I'm going to try and be as concise about my question as possible, but please ask for clarification if needed. I have a fillable PDF where users are given approx. 60-240 schedule choices (depending on which group they are in) which they rank numerically in order of their preference. Their selections are then exported to excel, normalized and imported into access where we determine who received what schedule based on their seniority and their ranking selections.

Obviously best practice is not to have a table with 240 fields (1 for each schedule option) so data normalization currently consists of converting the data structure from 240 fields to 3 fields (where there is 1 record for each scheduleID with it's ranking and a User ID to identify the individual.)
Current state: copying and transpose pasting the schedule data inside of excel and then copying, pasting and filling their user ID. The process for this is the same every time, and I am looking for the best way to automate this process instead of it taking hours (400 people are submitting these forms). Any input on the best way to do this is appreciated. I'm not great very well versed in VBA, but feel that is probably the best method.

RAW DATA AFTER EXPORTING FROM PDF FORM

Name	ID	Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5
Person1	U34567	1	7	10	11	4
Person 2	U29268	10	8	7	6	4

<tbody>
</tbody>

NEEDED FORMAT

ID	Schedule ID	Ranking
U34567	1	1
U34567	2	7
U34567	3	10
U34567	4	11
U34567	5	4
U29268	1	10
U29268	2	8
U29268	3	7
U29268	4	6
U29268	5	4

<tbody>
</tbody>

 

[mumps]

Try:

Sub FillData()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim LastRow2 As Long
    Dim lColumn As Long, ID As Range
    lColumn = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
    Sheets("Sheet2").Range("A1:C1") = Array("ID", "Schedule ID", "Ranking")
    For Each ID In Sheets("Sheet1").Range("B2:B" & LastRow)
        LastRow2 = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        Sheets("Sheet2").Cells(LastRow2, 1).Resize(lColumn - 2) = ID
        Sheets("Sheet1").Range(Cells(1, 3), Cells(1, lColumn)).Copy
        Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        ID.Offset(0, 1).Resize(1, lColumn - 2).Copy
        Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next ID
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Change the sheet names to suit your needs.

 

[datavizwiz]

Thank you so much! This works beautifully! I knew it could be done, but was hoping to avoid spending hours trying to figure out the best way and correct syntax. This will save me hours of time!

 

[mumps]

You are very welcome.