blackmamba89
New Member
- Joined
- Jun 28, 2022
- Messages
- 8
- Office Version
- 2019
- Platform
- MacOS
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!
I want it to look like this.
| 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 |
Rich (BB code):
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
Last edited by a moderator:
