Untitled

Option Explicit

Sub OrtofixSplitOrdersByVAT()

    Dim wb As Workbook
    Dim wsSrc As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    
    Dim cVal As Double
    Dim gVal As Double
    Dim ratio As Double
    Dim ratioRounded As Double
    Dim okC As Boolean
    Dim okG As Boolean
    
    Dim folderPath As String
    Dim userBaseName As String
    
    Dim file21 As String
    Dim file5 As String
    Dim fileMix As String
    
    Dim lines21 As Collection
    Dim lines5 As Collection
    Dim linesMix As Collection
    
    Dim lineText As String
    
    Set wb = ActiveWorkbook
    Set wsSrc = ActiveSheet
    
    If wb.Path = "" Then
        MsgBox "Please save the Excel file first, so the CSV files can be saved in the same folder.", vbExclamation
        Exit Sub
    End If
    
    userBaseName = InputBox("Enter the base file name:", "File name", GetFileNameWithoutExtension(wb.Name))
    userBaseName = Trim(userBaseName)
    
    If userBaseName = "" Then
        MsgBox "No file name entered. Cancelled.", vbExclamation
        Exit Sub
    End If
    
    userBaseName = CleanFileName(userBaseName)
    folderPath = wb.Path
    
    file21 = folderPath & Application.PathSeparator & userBaseName & "_21PVM.csv"
    file5 = folderPath & Application.PathSeparator & userBaseName & "_5PVM.csv"
    fileMix = folderPath & Application.PathSeparator & userBaseName & "_5-21PVM.csv"
    
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    lastCol = wsSrc.Cells(1, wsSrc.Columns.Count).End(xlToLeft).Column
    
    Set lines21 = New Collection
    Set lines5 = New Collection
    Set linesMix = New Collection
    
    ' No header row in source data, so start from row 1
    For r = 1 To lastRow
        
        okC = GetCellNumericValue(wsSrc.Cells(r, "C"), cVal)
        okG = GetCellNumericValue(wsSrc.Cells(r, "G"), gVal)
        
        If okC And okG Then
            If gVal <> 0 Then
                
                ratio = cVal / gVal
                ratioRounded = WorksheetFunction.Round(ratio, 2)
                
                lineText = BuildCSVLine(wsSrc, r, lastCol)
                
                If ratioRounded = 1.21 Then
                    lines21.Add lineText
                
                ElseIf ratioRounded = 1.05 Then
                    lines5.Add lineText
                
                ElseIf ratioRounded > 1.05 And ratioRounded < 1.21 Then
                    linesMix.Add lineText
                End If
                
            End If
        End If
        
    Next r
    
    WriteCollectionToUTF16CSV file21, lines21
    WriteCollectionToUTF16CSV file5, lines5
    WriteCollectionToUTF16CSV fileMix, linesMix
    
    MsgBox "Done." & vbCrLf & vbCrLf & _
           "Files saved in:" & vbCrLf & folderPath & vbCrLf & vbCrLf & _
           userBaseName & "_21PVM.csv" & vbCrLf & _
           userBaseName & "_5PVM.csv" & vbCrLf & _
           userBaseName & "_5-21PVM.csv", vbInformation

End Sub

Private Function GetCellNumericValue(ByVal rng As Range, ByRef resultValue As Double) As Boolean
    Dim rawVal As Variant
    
    rawVal = rng.Value2
    
    If IsError(rawVal) Then
        GetCellNumericValue = False
        Exit Function
    End If
    
    If IsNumeric(rawVal) Then
        resultValue = CDbl(rawVal)
        GetCellNumericValue = True
        Exit Function
    End If
    
    GetCellNumericValue = TryParseNumber(rng.Text, resultValue)
End Function

Private Function BuildCSVLine(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal lastCol As Long) As String
    Dim c As Long
    Dim cellText As String
    Dim lineText As String
    
    lineText = ""
    
    For c = 1 To lastCol
        cellText = ws.Cells(rowNum, c).Text
        cellText = Replace(cellText, """", """""")
        
        If c = 1 Then
            cellText = """" & cellText & """"
        End If
        
        If c = 1 Then
            lineText = cellText
        Else
            lineText = lineText & ";" & cellText
        End If
    Next c
    
    BuildCSVLine = lineText
End Function

Private Function TryParseNumber(ByVal rawText As String, ByRef resultValue As Double) As Boolean
    Dim s As String
    
    s = Trim(rawText)
    
    If s = "" Then
        TryParseNumber = False
        Exit Function
    End If
    
    s = Replace(s, Chr(160), "")
    s = Replace(s, " ", "")
    s = Replace(s, "€", "")
    
    If InStr(s, ",") > 0 And InStr(s, ".") > 0 Then
        s = Replace(s, ".", "")
        s = Replace(s, ",", ".")
    ElseIf InStr(s, ",") > 0 Then
        s = Replace(s, ",", ".")
    End If
    
    If IsNumeric(s) Then
        resultValue = CDbl(s)
        TryParseNumber = True
    Else
        TryParseNumber = False
    End If
End Function

Private Sub WriteCollectionToUTF16CSV(ByVal fullPath As String, ByVal lines As Collection)
    Dim fileNum As Integer
    Dim i As Long
    Dim textOut As String
    Dim bytes() As Byte
    Dim bom(1) As Byte
    
    textOut = ""
    
    For i = 1 To lines.Count
        textOut = textOut & CStr(lines(i)) & vbCrLf
    Next i
    
    fileNum = FreeFile
    Open fullPath For Binary As #fileNum
    
    bom(0) = &HFF
    bom(1) = &HFE
    Put #fileNum, , bom
    
    bytes = textOut
    Put #fileNum, , bytes
    
    Close #fileNum
End Sub

Private Function GetFileNameWithoutExtension(ByVal fileName As String) As String
    Dim p As Long
    
    p = InStrRev(fileName, ".")
    
    If p > 0 Then
        GetFileNameWithoutExtension = Left(fileName, p - 1)
    Else
        GetFileNameWithoutExtension = fileName
    End If
End Function

Private Function CleanFileName(ByVal s As String) As String
    Dim badChars As Variant
    Dim i As Long
    
    badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    
    For i = LBound(badChars) To UBound(badChars)
        s = Replace(s, badChars(i), "_")
    Next i
    
    CleanFileName = s
End Function