using vba excel to unpivot with multiple categories (1 w/ 4 columns & 1 w/ 5 columns) of data

[blackmamba89]

Hello, I work with a lot of spreadsheets on my job and one of the most important ones comes from a survey and automatically imports into a spreadsheet in Excel. Unfortunately, the survey displays multiples of hours#1 instead of just putting it into one column and so and so forth as seen below in Tb#1. My goal is to convert the Tb#1 to look like Tb#2 using vba through unpivoting the columns so that it will be easier for my colleagues to work with the data. Of course, below is just some fake data but similar in format. I have also posted my code below. I'm getting an error: "Object variables w/ block variable not set 91" at the bolded line . Any help will be appreciated!

usr	Company	Dept.#	Dept1	Dept2	Dept3	Dept4	Hr1	Hr1	Hr1	Hr1	Hr2	Hr2	Hr2	Hr3	Hr3	Hr4
xxxx	OS	1	Train				20
xxxx	OPC	2	Poxy1	Poxy2				45			38
xxxx	Oxy R	4	H1	H2	H3	H4				22			89		36	25
xxxx	HPK	3	Test1	Test2	Test3				99			52		90
xxxx	Mano	1	Porp				42
xxxx	Macro	2	Otto1	Otto2				75			23

I want it to look like this.

usr	Company	Dept.#	Dept	Hrs
xxxx	OS	1	Train	20
xxxx	OPC	2	Poxy1	45
xxxx	OPC	2	Poxy2	38
xxxx	Oxy R	4	H1	22
xxxx	Oxy R	4	H2	89
xxxx	Oxy R	4	H3	36
xxxx	Oxy R	4	H4	25
xxxx	HPK	3	Test1	99
xxxx	HPK	3	Test2	52
xxx	HPK	3	Test3	90
xxxx	Mano	1	Porp	42
xxxx	Macro	2	Otto1	75
xxxx	Macro	2	Otto2	23

Option Explicit

Sub TransformData()

Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim hdr
Dim rgDept As Range: Dim cell As Range:
Dim i As Long: Dim cnt As Long: Dim r As Long: Dim rgFill As Range: Dim rgHr As Range


Dim q As Integer
Worksheets("Sheet1").Select
q = 1
Do While Cells(q, 1) <> ""
   Cells(q, 8) = Cells(q, 8) & Cells(q, 9) & Cells(q, 10) & Cells(q, 11) & Cells(q,
12) & Cells(q, 13) & Cells(q, 14) _
    & Cells(q, 15) & Cells(q, 16) & Cells(q, 17)
    q = q + 1
Loop
Columns("H:H").EntireColumn.AutoFit
Sheet1.Range("H1").Value = "Hrs"

'setting the sheet into variable - change if needed
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
'clear all cells in sh2
sh2.Cells.ClearContents

'the header which will be in sh2 coming from sh1 header as hdr variable
hdr = Array("Usr", "Company", "Dept1", "Dept2", "Dept3", "Dept4", "Hr1", "Hr2",
"Hr3", "Hr4")

'put the data from sh1 to sh2 according to the header name defined in rgFill
For i = LBound(hdr) To UBound(hdr)
    sh1.Columns(sh1.Rows(1).Find(hdr(i)).Column).Copy Destination:=sh2.Columns(i + 1)
Next

'start row
r = 2

Do
'set the range for Unit Name according to the looped row into variable rgUnit _
this is how it will be pasted on Sheet 2
Set rgDept = sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6)) ' sets the range of the Unit
Set rgHr = rgDept.Offset(0, 4)

'count how many data in rgUnit as cnt variable
cnt = Application.CountA(rgUnit)

    'if cnt > 1, copy the looped row then insert under it as many as cnt - 1
    If cnt > 1 Then
        sh2.Rows(r).Copy
        sh2.Rows(r + 1 & ":" & r + cnt - 1).Insert Shift:=xlDown
        Application.CutCopyMode = False
    End If

'fill the unit name
Set rgFill = rgDept.Resize(1, 1)
For Each cell In rgDept.SpecialCells(xlCellTypeConstants)
    rgFill.Value = cell.Value
    Set rgFill = rgFill.Offset(1, 0)
Next

'fill the number of actual hours
Set rgFill = rgHr.Resize(1, 1)
On Error Resume Next
For Each cell In rgHr.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
    rgFill.Value = cell.Value
    Set rgFill = rgFill.Offset(1, 0)
Next

'increase the row value by add the cnt value
r = r + cnt
   
' Don't change this one.
Loop Until Application.CountA(sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))) = 0 
'finish the loop when rgUnit has no data

'delete unneeded column
rgDept.Resize(rgUnit.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete

'give the correct name for unit and color header in sh2
sh2.Range("H1").Value = "Hrs"

Sheets(2).Buttons.Delete

MsgBox "Data converted!"

End Sub

 

[Fluff]

How about

Sub blackmamba()
   Dim Ary As Variant, Nary As Variant, Cary As Variant
   Dim r As Long, c As Long, nr As Long, cc As Long
   
   Cary = Array("0811", 1214, 1516, 1717)
   With Sheets("Sheet1")
      Ary = .Range("A2:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary) * 4, 1 To 5)
   
   For r = 1 To UBound(Ary)
      For c = 4 To 7
         If Ary(r, c) = "" Then Exit For
         nr = nr + 1
         Nary(nr, 1) = Ary(r, 1): Nary(nr, 2) = Ary(r, 2): Nary(nr, 3) = Ary(r, 3)
         Nary(nr, 4) = Ary(r, c)
         For cc = Left(Cary(c - 4), 2) To Right(Cary(c - 4), 2)
            Nary(nr, 5) = Nary(nr, 5) & Ary(r, cc)
         Next cc
      Next c
   Next r
   With Sheets("Sheet2")
      .UsedRange.ClearContents
      .Range("A1").Resize(, 5).Value = Array("usr", "Company", "Dept.#", "Dept", "Hrs")
      .Range("A2").Resize(nr, 5).Value = Nary
   End With
End Sub

 

[blackmamba89]

How about

Sub blackmamba()
   Dim Ary As Variant, Nary As Variant, Cary As Variant
   Dim r As Long, c As Long, nr As Long, cc As Long
  
   Cary = Array("0811", 1214, 1516, 1717)
   With Sheets("Sheet1")
      Ary = .Range("A2:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary) * 4, 1 To 5)
  
   For r = 1 To UBound(Ary)
      For c = 4 To 7
         If Ary(r, c) = "" Then Exit For
         nr = nr + 1
         Nary(nr, 1) = Ary(r, 1): Nary(nr, 2) = Ary(r, 2): Nary(nr, 3) = Ary(r, 3)
         Nary(nr, 4) = Ary(r, c)
         For cc = Left(Cary(c - 4), 2) To Right(Cary(c - 4), 2)
            Nary(nr, 5) = Nary(nr, 5) & Ary(r, cc)
         Next cc
      Next c
   Next r
   With Sheets("Sheet2")
      .UsedRange.ClearContents
      .Range("A1").Resize(, 5).Value = Array("usr", "Company", "Dept.#", "Dept", "Hrs")
      .Range("A2").Resize(nr, 5).Value = Nary
   End With
End Sub

Dude, that did the trick! Thank you! I tried to be as thorough as possible when posting. I appreciate you taking the time.

 

[Fluff]

You're welcome & thanks for the feedback.

 

[blackmamba89]

You're welcome & thanks for the feedback.

No problem! Thank you man. One more question then I'll let you go: say I wanted to add another category to coincide with the Hrs categories. Would the code be difficult to manipulate that to reflect that change? I have attached a picture of what I'm referring to below. The real file I'm working with is WAY larger in size and has more categories so I'm just wondering about that one.

 

[Fluff]

Are you looking to return anything from the TR# cells, as they are all blank?

 

[blackmamba89]

Are you looking to return anything from the TR# cells, as they are all blank?

Yep! my bad. Ignore that first picture. This is the correct one. I do plan to return more numbers in this one as well.

 

[Fluff]

How about

Sub blackmamba()
   Dim Ary As Variant, Nary As Variant, Cary As Variant
   Dim r As Long, c As Long, nr As Long, cc As Long
   
   Cary = Array("0814", 1620, 2224, 2626)
   With Sheets("Sheet1")
      Ary = .Range("A2:AA" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Ary) * 4, 1 To 6)
   
   For r = 1 To UBound(Ary)
      For c = 4 To 7
         If Ary(r, c) = "" Then Exit For
         nr = nr + 1
         Nary(nr, 1) = Ary(r, 1): Nary(nr, 2) = Ary(r, 2): Nary(nr, 3) = Ary(r, 3)
         Nary(nr, 4) = Ary(r, c)
         For cc = Left(Cary(c - 4), 2) To Right(Cary(c - 4), 2) Step 2
            Nary(nr, 5) = Nary(nr, 5) & Ary(r, cc)
            Nary(nr, 6) = Nary(nr, 6) & Ary(r, cc + 1)
         Next cc
      Next c
   Next r
   With Sheets("Sheet2")
      .UsedRange.ClearContents
      .Range("A1").Resize(, 5).Value = Array("usr", "Company", "Dept.#", "Dept", "Hrs", "Tr")
      .Range("A2").Resize(nr, 6).Value = Nary
   End With
End Sub

 

[blackmamba89]

You're amazing! I can't thank you enough. I'll use your blueprint to definitely add all the other categories I need to add in the real file. I truly appreciate it! I liked, and marked as solution. This site isn't like stackoverflow where you get badges for helping people but if there is anything else I can do to let me know.

 

[Fluff]

if there is anything else I can do to let me know.

Nothing else