I'm hoping you can help me improve a bit of code that I cobbled together as a VBA novice. The basic premise is to convert a matrix to a list. My matrix (Table 1) includes unique ID, personal info, unique key (same as unique ID) and assigned roles where an "X" matches the name (row) with the role (column). It is easy to create the reverse pivot table (Table 2) and the result is a table with Unique ID, Role, and 'X'. The code below goes back to Table 1 and stiches back personal info by matching unique ID (Table 1) with Unique Key (Table 2). It works - just VERRRRY slow as there will be 10-20k lines on Table 2.
Table 1 (the matrix). In my code it is called 'RDBMergeSheet'
Unique ID - Personal info - Unique Key (same as unique ID) - Roles (indicated with an X in the cell which aligns with the appropriate role column. There are multiple Xs)
Table 2 (the reverse pivot). In my code it is called 'Data Table'
Unique Key - Role (now as a title). I filtered and removed all blanks. Note that the same unique key will appear for each role that that user has
I want to add the Unique ID's personal info from Table 1 for each Unique Key.
Sub Fill_Info() 'fills End User Info into Data Table worksheet Dim LastC As Long Dim LastR As Long Dim LastR2 As Long Dim l As Long Dim i As Integer Dim d As Long Dim ColCount As Long Dim Dept_Row As Long Dim Dept_Clm As Long Dim ID As Range Dim foundID As Range Dim DTableLastC As Long Dim DTableLastR As Long Dim Dtablel As Long Sheets("RDBMergeSheet").Select LastC = LastCol(ActiveSheet) LastR = LastRow(ActiveSheet) 'assums unique user key column is between A1 and Z1 l = Application.WorksheetFunction.Match("Unique User Key", Range("A1:Z1"), 0) ActiveSheet.Range(Cells(2, 1), Cells(LastR, l - 1)).Name = "info_Range" Range("info_range").Activate Application.CutCopyMode = False Selection.Copy Sheets("Data Table").Select LastR2 = LastRow(ActiveSheet) ActiveSheet.Range(Cells(2, 1), Cells(LastR2, 1)).Name = "Unique_Keys" ColCount = Range("info_range").Columns.Count ActiveSheet.Range(Cells(1, 1), Cells(1, ColCount)).Name = "Unique_Keys_Col" For Each ID In Sheets("data table").Range("A2:A" & LastR2) Set foundID = Sheets("RDBMergeSheet").Range("A:A").find(ID, LookIn:=xlValues, lookat:=xlWhole) If Not foundID Is Nothing Then Worksheets("RDBMergeSheet").Cells(foundID.Row, 2).Resize(, ColCount).Copy Sheets("data table").Range("D" & ID.Row) End If Next ID Application.Goto Reference:="Header_Range" Selection.Copy Sheets("Data Table").Select Range("D1").Select ActiveSheet.paste Application.CutCopyMode = False ' Defines the range for the Data Pivot Table Sheets("Data Table").Select DTableLastC = LastCol(ActiveSheet) DTableLastR = LastRow(ActiveSheet) ActiveSheet.Range(Cells(1, 1), Cells(DTableLastR, DTableLastC)).Name = "Data_Pivot_Table" End Sub