VBA to export data with altered format to a csv

[Drivium]

I have a user with an excel doc formatted like this (source):



Proj
CostType
Descr
2021
2022
2023
2024


Proj1
CostType1
words1
123
845
224



Proj2
CostType2
words2

545




Proj1
CostType5
words3
154

4456



Proj3
CostType2
words4
115
5445
12324




I've been asked to create a vba script to dump it to a csv file in this format for a bulk upload (target):



Proj
Description
CostType1
CostType2
CostType3
CostType4
CostType5
CostType6
CostType7
CostType8
StartDate
EndDate
ExtraCol1
ExtraCol2


Proj1
words1
546
2112

124
254



1-1-2021
1-1-2022




Proj2
words2
456

454
5654




1-1-2021
1-1-2022




Proj1
words3
54
45454






1-1-2022
1-1-2023




Proj3
words4
54512
121
4
85




1-1-2022
1-1-2023





I've not tried to iterate in this way before, but it seems like I'd need to start with the date in the source. So, for every row for 2021, I need to grab the first 3 columns and break the costs out for the output, then do the same for 2022. So, I'm essentially switching from dates as columns to cost type as columns. The end date is just the start date + 1 year and they'll always have "1-1-xxxx". Also, the dates in the source extend all the way to 2060. Any one of these columns may be empty. Hope this makes sense. Any help would be greatly appreciated.

[arnelgp]

can you use Formula?
https://www.dropbox.com/scl/fi/r4e3vyf9rg1hpjxfq1kic/BOOK5.xlsx?dl=0&rlkey=en34bphwxl20jab107h5b0vh4

[Drivium]

can you use Formula?
https://www.dropbox.com/scl/fi/r4e3vyf9rg1hpjxfq1kic/BOOK5.xlsx?dl=0&rlkey=en34bphwxl20jab107h5b0vh4

Thank you. This seems close, but without summing the values, I just need them put into the right spot. Also, the associated year column (StartDate) needs to be assigned to the row. So, somehow, the year column from the source needs to be put in the row with it's value. I should have used the same values from the source in the target for the example. That probably just made things confusing. I can't seem to edit it now.

[p45cal]

Is the green table the correct output for the actual figures in the blue table?:
28907

[Paul_Hossler]

I should have used the same values from the source in the target for the example. That probably just made things confusing. I can't seem to edit it now.

1. That would have helped

2. I think this would be it. It's not 100% efficient, but seems good enough and the logic is straight-forward




Option Explicit


Sub Reformat()
Dim sOut As String
Dim wsOut As Worksheet
Dim rIn As Range
Dim rowIn As Long, rowOut As Long, colIn As Long, colCostType As Long

Set rIn = ActiveSheet.Cells(1, 1).CurrentRegion




'delete existing
sOut = ActiveSheet.Name & "-Out"
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(sOut).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set wsOut = Worksheets.Add
ActiveSheet.Name = sOut
rowOut = 1

wsOut.Cells(1, 1).Resize(1, 14).Value = Array("Proj", "Description", "CostType1", "CostType2", "CostType3", "CostType4", "CostType5", "CostType6", "CostType7", "CostType8", "StartDate", "EndDate", "ExtraCol1", "ExtraCol2")


rowOut = rowOut + 1


With rIn
For rowIn = 2 To .Rows.Count
For colIn = 4 To .Columns.Count
'Project
wsOut.Cells(rowOut, 1).Value = .Cells(rowIn, 1).Value

'description
wsOut.Cells(rowOut, 2).Value = .Cells(rowIn, 3).Value


'cost type
colCostType = Application.WorksheetFunction.Match(.Cells(rowIn, 2).Value, wsOut.Rows(1), 0)

'if there's a value
If .Cells(rowIn, colIn).Value > 0 Then
wsOut.Cells(rowOut, colCostType).Value = .Cells(rowIn, colIn).Value
wsOut.Cells(rowOut, 11).Value = DateSerial(.Cells(1, colIn).Value, 1, 1)
wsOut.Cells(rowOut, 12).Value = DateSerial(.Cells(1, colIn).Value + 1, 1, 1)

rowOut = rowOut + 1
End If
Next colIn
Next rowIn
End With




'delete the extra empty row
With wsOut.Cells(1, 1).CurrentRegion
If Len(Cells(.Rows.Count, 12).Value) = 0 Then .Rows(.Rows.Count).Delete
End With





End Sub

[Drivium]

Option Explicit


Sub Reformat()
Dim sOut As String
Dim wsOut As Worksheet
Dim rIn As Range
Dim rowIn As Long, rowOut As Long, colIn As Long, colCostType As Long

Set rIn = ActiveSheet.Cells(1, 1).CurrentRegion




'delete existing
sOut = ActiveSheet.Name & "-Out"
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(sOut).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set wsOut = Worksheets.Add
ActiveSheet.Name = sOut
rowOut = 1

wsOut.Cells(1, 1).Resize(1, 14).Value = Array("Proj", "Description", "CostType1", "CostType2", "CostType3", "CostType4", "CostType5", "CostType6", "CostType7", "CostType8", "StartDate", "EndDate", "ExtraCol1", "ExtraCol2")


rowOut = rowOut + 1


With rIn
For rowIn = 2 To .Rows.Count
For colIn = 4 To .Columns.Count
'Project
wsOut.Cells(rowOut, 1).Value = .Cells(rowIn, 1).Value

'description
wsOut.Cells(rowOut, 2).Value = .Cells(rowIn, 3).Value


'cost type
colCostType = Application.WorksheetFunction.Match(.Cells(rowIn, 2).Value, wsOut.Rows(1), 0)

'if there's a value
If .Cells(rowIn, colIn).Value > 0 Then
wsOut.Cells(rowOut, colCostType).Value = .Cells(rowIn, colIn).Value
wsOut.Cells(rowOut, 11).Value = DateSerial(.Cells(1, colIn).Value, 1, 1)
wsOut.Cells(rowOut, 12).Value = DateSerial(.Cells(1, colIn).Value + 1, 1, 1)

rowOut = rowOut + 1
End If
Next colIn
Next rowIn
End With




'delete the extra empty row
With wsOut.Cells(1, 1).CurrentRegion
If Len(Cells(.Rows.Count, 12).Value) = 0 Then .Rows(.Rows.Count).Delete
End With





End Sub




This is awesome and works beautifully in my example! I figured I'd be able to adapt it for my needs, but my actual spreadsheet isn't quite structured the way it is in my example. The headers start on row 3 and data on row 4. Col C and D can be ignored. Some of the actual budget categories have spaces and Match doesn't seem to like that. Also, all cells in the source are formatted as General.

























Proj
Budget Category
junk
junk
Desc
2021
2022
2023
2024


Proj1
Budget Savings


words1
123
4545




Proj2
Budget Cost


words2
515
321

4545


Proj1
Produced


words3

54
544



Proj3
Budget Savings


words4



5654



I apologize! I was attempting to make it easier for others to offer help, but may have produced the opposite result...

[Drivium]

Is the green table the correct output for the actual figures in the blue table?:
28907

Yes! Thank you. See my notes in another response about some caveats.

[Paul_Hossler]

It's not that Match does not like the spaces; the problem is that the Budget Category (Budget Savings, Budget Cost, ...) entries no longer match the originals (CostType1, ...) that Match was looking for




Option Explicit


Sub Reformat()
Dim sOut As String
Dim wsOut As Worksheet
Dim rIn As Range, rEnd As Range
Dim rowIn As Long, rowOut As Long, colIn As Long, colCostType As Long


With ActiveSheet
Set rEnd = .Cells(.Rows.Count, 1).End(xlUp)
Set rIn = Range(.Cells(3, 1), rEnd)
Set rIn = Intersect(rIn.EntireRow, rIn.CurrentRegion)
sOut = .Name & "-Out"
End With


'delete existing
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(sOut).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set wsOut = Worksheets.Add
ActiveSheet.Name = sOut
rowOut = 1

wsOut.Cells(1, 1).Resize(1, 14).Value = Array("Proj", "Description", "Budget Savings", "Budget Cost", "Produced", "CostType4", "CostType5", "CostType6", "CostType7", "CostType8", "StartDate", "EndDate", "ExtraCol1", "ExtraCol2")


rowOut = rowOut + 1


With rIn
For rowIn = 2 To .Rows.Count
For colIn = 6 To .Columns.Count
'Project
wsOut.Cells(rowOut, 1).Value = .Cells(rowIn, 1).Value

'description
wsOut.Cells(rowOut, 2).Value = .Cells(rowIn, 5).Value


'cost type
colCostType = Application.WorksheetFunction.Match(.Cells(rowIn, 2).Value, wsOut.Rows(1), 0)

'if there's a value
If .Cells(rowIn, colIn).Value > 0 Then
wsOut.Cells(rowOut, colCostType).Value = .Cells(rowIn, colIn).Value
wsOut.Cells(rowOut, 11).Value = DateSerial(.Cells(1, colIn).Value, 1, 1)
wsOut.Cells(rowOut, 12).Value = DateSerial(.Cells(1, colIn).Value + 1, 1, 1)

rowOut = rowOut + 1
End If
Next colIn
Next rowIn
End With




'delete the extra empty row
With wsOut.Cells(1, 1).CurrentRegion
If Len(Cells(.Rows.Count, 12).Value) = 0 Then .Rows(.Rows.Count).Delete
End With
End Sub

[Drivium]

Yes, you're right. Your solution got me what I needed. Super impressive the chaos this can order. Thank you very much. I'm seeing no option to mark your post as the correct answer.

[Paul_Hossler]

Thanks

Use #3 in my sig to mark it solved

[p45cal]

For what it's worth:
In the attached, the blue table is the source data with the following constraints:
It must be a table proper, called (as it is) Table1
There should be headers named exactly Proj, Budget Category and Desc
The 3rd and 4th columns can be any name (or not named) because they'll be ignored by dint of their position.
All other column headers will be taken as years (if those columns have no header or can't be converted to a year, you'll just get blanks in the Date Start/End columns.
Freedoms:
The table can be wherever you want on the sheet, even on another sheet.
Any number of year columns.
Anything in the Budgetary Category; new columns will be created/removed in the result table as necessary to accommodate the range of categories.
The columns can be in any order you want except for the 3rd and 4th (junk) columns which will be ignored, regardless of what they're called.
Any empty/blank/missing values in the Budget Category column will appear as a (blank) headed column.

All you have to do is right-click the green table (which can also be moved anywhere within the workbook) and choose Refresh.

Courtesy of Power Query (aka Get & Transform Data). No macros.