VBA to export data with altered format to a csv

[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