VBA to export data with altered format to a csv

[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