macro help
Hello,
I need help with a macro for a project i am working on. I am bringing data in from an xml spreadsheet. The data is benefit information for employees.
One of the columns I am bringing into the spreadsheet is named 'CategoryName.' This field can have multiple category names associated with one person. So, it is creating multiple rows for each person. 1 row per category name. The column to the right of 'CategoryName,' is 'CategoryValue.' This column contains a value that is associated with the value in the 'CategoryName' column to the left.
I need to transpose the 'CategoryName' values into the header row. For instance, if there are 8 rows created because their are 8 values for 'CategoryName,' I need those 8 values transposed into the header row. One thing to keep in mind, if there are 8 values for one person, each person has the exact same 8 values, so it only need to be transposed once. After it is transposed, the original 'CategoryName' column can be deleted.
After that, I need the associated value in the 'CategoryValue' column, transposed directly under the new column header that was transposed from the the 'CategoryName.' So, if their are 8 new columns transposed from the 'CategoryName,' each column will have a value underneath the heading that was transposed from the 'CategoryValue' field. Once this is done, the 'CategoryValue' column can be deleted.
After this is transposed, all information I need will now be on one line. All of the duplocate rows can now be deleted. I have attached a screenshot, as I am sure this is confusing and the screenshot might help. The first sheet is the initial sheet that i get when I import the data from the xml. The second sheet shows how I need it to look after I use the macro.
One thing to keep in mind, the number of columns and rows and be different based on the client. The constant is the name of the columns, 'CategoryName' and 'CategoryValue.' So, the transposing would probably have to be based off of the column names.
Thanks for any help. I would really appreciate it. I have been working on it for awhile and can't get anywhere. I really don't know VB that well, so that is really a constraint.
| Attachment | Size |
|---|---|
| transpose1.xlsx | 16.77 KB |
Use Pivot Table
Use Pivot Table
Would a pivot table
Would a pivot table accomplish all of this? I have been working on a macro, but I am stuck now. Basically, for this macro I have, it will transpose the 3rd and 4th column. So, I have to put the data I want transposed in those columns. Is their a way to transpose based on column name instead of location? Also, I want it to delete the duplicate row for everyone, since each person has one duplicate row. It could match on the SSN to delete. Here is the copy of the macro i have so far. I am hoping it just needs a little tweaking, but i am not good with VB, so I am struggling now.
Sub PutOnOneRow()
Dim X As Long, Start As Long, LastRow As Long
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Start = 2
For X = 3 To LastRow + 1
If Cells(X, "A").Value & Cells(X, "B").Value <> Cells(X - 1, "A").Value & Cells(X - 1, "B").Value Then
Cells(Start, "E").Resize(, X - Start - 1) = WorksheetFunction.Transpose(Cells(Start + 1, "D").Resize(X - Start - 1))
If Start = 2 Then
Range("D1").Resize(, X - 2) = WorksheetFunction.Transpose(Range("C2:C" & (X - 1)))
End If
Start = X
End If
Next
Columns("C").Delete
On Error Resume Next
Range("D" & 2 & ":D" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Try this code. I have not
Try this code. I have not modified your code; rather written my own. Its currently writing the values in sheet3 without any format. You can make change to the code accordingly to change the target sheet.
Sub RunMe()
Dim rngData As Range
Dim wksTgt As Worksheet
Dim arrUniq
Dim rngTgt As Range
Dim rngCell As Range
Dim rngSrc As Range
Dim rngCellSrc As Range
Dim strConc As String
Dim strConc2 As String
Set rngData = Sheet1.Range("Table1[[#All],[SSN]:[City]]")
Set wksTgt = Sheet3 'Change this as per your requirement
wksTgt.UsedRange.ClearContents
rngData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wksTgt.Range("A1"), Unique:=True
With rngData
arrUniq = UniqueRangeToArray(Sheet1.Range("Table1[CategoryName]"))
End With
Set rngTgt = wksTgt.Range("A1").End(xlToRight).Offset(, 1)
rngTgt.Resize(1, UBound(arrUniq, 1)).Value = Application.Transpose(arrUniq)
Set rngTgt = rngTgt.CurrentRegion.SpecialCells(xlCellTypeBlanks)
Set rngSrc = Sheet1.Range("Table1")
For Each rngCell In rngTgt.Cells
With rngCell.Parent
strConc = .Cells(rngCell.Row, 1) & .Cells(rngCell.Row, 2) & .Cells(rngCell.Row, 3) & .Cells(rngCell.Row, 4) & _
.Cells(1, rngCell.Column)
End With
For Each rngCellSrc In rngSrc.Rows
With rngCellSrc.Parent
strConc2 = .Cells(rngCellSrc.Row, 1) & .Cells(rngCellSrc.Row, 2) & .Cells(rngCellSrc.Row, 3) & .Cells(rngCellSrc.Row, 4) & _
.Cells(rngCellSrc.Row, 5)
If strConc = strConc2 Then
rngCell.Value = .Cells(rngCellSrc.Row, 6)
End If
End With
Next rngCellSrc
Next rngCell
Set rngData = Nothing
Set wksTgt = Nothing
Erase arrUniq
Set rngTgt = Nothing
Set rngCell = Nothing
Set rngSrc = Nothing
Set rngCellSrc = Nothing
End Sub
Function UniqueRangeToArray(rng As Range) As Variant
Dim i As Long
Dim arr As Variant
Dim Unique As New Collection
arr = rng
For i = 1 To UBound(arr, 1)
On Error Resume Next
Unique.Add arr(i, 1), CStr(arr(i, 1))
Next
ReDim arr(1 To Unique.Count, 1 To 1)
For i = 1 To Unique.Count
arr(i, 1) = Unique(i)
Next
UniqueRangeToArray = arr
Set Unique = Nothing
End Function