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/r4e3v...0jab107h5b0vh4

[Drivium]

can you use Formula?
https://www.dropbox.com/scl/fi/r4e3v...0jab107h5b0vh4

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?:
2021-09-01_134201.jpg

[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?:
2021-09-01_134201.jpg

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.