[Tasos]

Καλησπέρα Νίκο!
Ήσουν κατατοπιστικότατος!
Με κάποιες αλλαγές που έγιναν πιστεύω να σε εξυπηρετεί ο παρακάτω κώδικας:

Option Explicit

Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
                                             ByVal lpPath As String) As Long

Const ThePath = "C:\Data\"    'Το όνομα του φακέλου

Sub Export2csv()
    Dim rng As Range, d As Range, strCSV As String, tmpString As String, fso As Object, _
        oStream As Object, i As Integer, r As Long, RowsCount As Long, _
        c4Seperator As String, c3Seperator As String, c2Seperator As String, cSeperator As String

    'Αν χρησιμοποιηθεί το σύμβολο ";" ως οριοθέτης,
    'θα πρέπει να αφαιρεθεί το τελευταίο "True" από τη γραμμή "Set oStream =..."
    c4Seperator = vbTab & vbTab & vbTab & vbTab & vbTab  '";;;;"
    c3Seperator = vbTab & vbTab & vbTab & vbTab    '";;;"
    c2Seperator = vbTab & vbTab    '";;" '
    cSeperator = vbTab    '";"
    MakeSureDirectoryPathExists "C:\Data\"

    With Application
        .ScreenUpdating = False

        r = Range("B" & Rows.Count).End(xlUp).Row
        Set rng = Range("B2:B" & r)
        RowsCount = rng.Rows.Count

        For i = Range("G1").Column To Range("G1").End(xlToRight).Column    'όλοι οι κωδικοί από το G1 έως τον τελευταίο
            Set d = Range(Cells(2, i), Cells(RowsCount, i))
        '   d.Select
            For r = 1 To RowsCount
                If d(r) <> 0 Then
                    tmpString = _
                    c2Seperator & _
                                rng(r).Text & _
                                c4Seperator & _
                                d(r).Text & _
                                cSeperator & _
                                rng(r).Offset(, 2).Text & _
                                c4Seperator & _
                              1 & _
                                c3Seperator & _
                                rng(r).Offset(, 3).Text & _
                                vbNewLine
                    strCSV = strCSV & tmpString
                    tmpString = vbNullString
                End If
            Next
            tmpString = Cells(1, i) & "_" & Replace(Format(Now, "dd_mm_yy hh:mm:ss"), ":", "_") & ".csv"
            Set fso = CreateObject("Scripting.FileSystemObject")

            'Αν χρησιμοποιηθεί το σύμβολο ";" ως οριοθέτης,θα πρέπει να αφαιρεθεί το τελευταίο "True"
            Set oStream = fso.CreateTextFile(ThePath & tmpString, True, True)
            oStream.Write strCSV
            oStream.Close
            Set fso = Nothing
            strCSV = vbNullString
            tmpString = vbNullString
        Next

        tmpString = ThePath & "All_" & Replace(Format(Now, "dd_mm_yy hh:mm:ss"), ":", "_") & ".xls"
        ActiveSheet.Copy
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
        ActiveWorkbook.SaveAs tmpString, ThisWorkbook.FileFormat
        ActiveWorkbook.Close , False
        .ScreenUpdating = True
    End With
End Sub

Καλή συνέχεια!

Τάσος