[Tasos]

Φίλε Νίκο,
ο παρακάτω κώδικας

• Παίρνει τις στήλες: [Α/Α], [ΠΕΡΙΓΡΑΦΗ], [ΚΩΔΙΚΟΣ ΥΛΙΚΟΥ], [ΚΩΔΙΚΟΣ], [Ημερομηνία]
  καθώς και τη στήλη [Κωδικός (στήλες G,H,I,J, μια κάθε φορά)] και μόνον εκείνες τις γραμμές που ο κώδικας (πχ. A1256 ) δεν είναι μηδέν.
• Τις αποθηκεύει σε μορφή Unicode προσθέτοντας και την ημερομηνία και ώρα σε
  μορφή που να είναι αποδεκτή από τα Windows.
  Οι στήλες διαχωρίζονται με Tab για περισσότερη συμβατότητα.
• Εξάγει το τρέχον φύλλο σε νέο βιβλίο, μετατρέπει τυχόν τύπους σε σταθερές τιμές
  και αποθηκεύει το νέο αυτό βιβλίο στον ίδιο φάκελο με τα *.csv.

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

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

Sub Export2csv()
    Dim rng As Range, rngRow As Range, c 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

    MakeSureDirectoryPathExists "C:\Data\"

    With Application
        .ScreenUpdating = False

        r = Range("A" & Rows.Count).End(xlUp).Row
        Set rng = Range("A1:E" & r)
        RowsCount = rng.Rows.Count
        For i = Range("G1").Column To Range("G1").End(xlToRight).Column 'όλοι οι κωδικοί από το G1 έως τον τελευταίο
            Set d = Range(Cells(1, i), Cells(RowsCount, i))
            For r = 1 To RowsCount
                Set rngRow = rng.Rows(r)
                If d(r) <> 0 Then
                    For Each c In rngRow.Cells
                        tmpString = tmpString & c.Text & vbTab
                    Next
                    tmpString = tmpString & d(r).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")
            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

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

Τάσος