Would someone please help me make a VBA script to do this. See photo below. All data is consistent I have bout 500 rows of data.
Sub RearrangeData()
'Assumes read date data in groups of 3 rows each and first read date in cell A2
Dim Hdrs As Variant, lR As Long, Rws As Long, i As Long
Application.ScreenUpdating = False
Hdrs = Array("Read Date", "OFF PEAK", "ON PEAK", "SHLDR PEAK")
Range("E1:H1").Value = Hdrs
lR = Range("A" & Rows.Count).End(xlUp).Row
Rws = Range("A2:A" & lR).Rows.Count
If Rws / 3 <> Int(Rws / 3) Then
MsgBox "Must be three data points per read date"
Exit Sub
End If
For i = 1 To Rws Step 3
lR = Range("E" & Rows.Count).End(xlUp).Row + 1
Range("E" & lR).Value = Range("A1").Offset(i, 0)
Range("F" & lR, "H" & lR).Value = _
WorksheetFunction.Transpose(Range("B1").Offset(i, 0).Resize(3, 1))
Next i
Columns("E:H").AutoFit
Application.ScreenUpdating = True
End Sub| Excel 2007 | |||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | H | I | |||
| 1 | Read Date | Consumption Amount | Reading Type | ||||||||
| 2 | 7/29/2014 | 822 kWh | OFF PEAK | ||||||||
| 3 | 7/29/2014 | 126 kWh | ON PEAK | ||||||||
| 4 | 7/29/2014 | 68 kWh | SHLDR PEAK | ||||||||
| 5 | 6/26/2014 | 673 kWh | OFF PEAK | ||||||||
| 6 | 6/26/2014 | 116 kWh | ON PEAK | ||||||||
| 7 | 6/26/2014 | 69 kWh | SHLDR PEAK | ||||||||
| 8 | |||||||||||
Sheet1 | |||||||||||
| Excel 2007 | |||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | H | I | |||
| 1 | Read Date | Consumption Amount | Reading Type | Read Date | OFF PEAK | ON PEAK | SHLDR PEAK | ||||
| 2 | 7/29/2014 | 822 kWh | OFF PEAK | 7/29/2014 | 822 kWh | 126 kWh | 68 kWh | ||||
| 3 | 7/29/2014 | 126 kWh | ON PEAK | 6/26/2014 | 673 kWh | 116 kWh | 69 kWh | ||||
| 4 | 7/29/2014 | 68 kWh | SHLDR PEAK | ||||||||
| 5 | 6/26/2014 | 673 kWh | OFF PEAK | ||||||||
| 6 | 6/26/2014 | 116 kWh | ON PEAK | ||||||||
| 7 | 6/26/2014 | 69 kWh | SHLDR PEAK | ||||||||
| 8 | |||||||||||
Sheet1 | |||||||||||
Sub ReorgData()
' hiker95, 08/03/2014, ME796232
Dim lr As Long, c As Range, drng As Range, trng As Range
Application.ScreenUpdating = False
Columns("F:I").ClearContents
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(6), Unique:=True
Cells(1, 7).Resize(, 3).Value = Array("OFF PEAK", "ON PEAK", "SHLDR PEAK")
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("A2:A" & lr)
Set drng = Columns(6).Find(c, LookAt:=xlWhole)
Set trng = Rows(1).Find(c.Offset(, 2).Value, LookAt:=xlWhole)
If (Not drng Is Nothing) * (Not trng Is Nothing) Then
Cells(drng.Row, trng.Column).Value = c.Offset(, 1).Value
End If
Next c
Columns("F:I").AutoFit
Application.ScreenUpdating = True
End Sub
