Need Help with Excel to CSV Macro

[Jopapoo]

Need to convert a excel to CSV format with specific condition.
[TABLE="width: 500"]
<tbody>[TR]
[TD]DEp[/TD]
[TD]YY[/TD]
[TD]DD[/TD]
[TD]YTD[/TD]
[TD]Invoice Number[/TD]
[/TR]
[TR]
[TD]ab[/TD]
[TD]12[/TD]
[TD]1[/TD]
[TD]Y[/TD]
[TD]123456[/TD]
[/TR]
[TR]
[TD]as[/TD]
[TD]11[/TD]
[TD]2[/TD]
[TD]N[/TD]
[TD]123456[/TD]
[/TR]
[TR]
[TD]qw[/TD]
[TD]1[/TD]
[TD]1[/TD]
[TD]Y[/TD]
[TD]466578[/TD]
[/TR]
[TR]
[TD]qq[/TD]
[TD]2[/TD]
[TD]1[/TD]
[TD]Y[/TD]
[TD]123874[/TD]
[/TR]
</tbody>[/TABLE]

1) Need to filter using invoice number using unique number
2) Copy the visible cells expect the last column(invoice #)
3) Save the file with invoice number
4) I have the code to all expect the deleting the last column(invoice#)

My Code :

Sub Button2_Click()
Dim LR As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False


iCol = 5
strOutputFolder = "D:\temp"


Set ws = ThisWorkbook.ActiveSheet
Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)


If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
Workbooks.Add

ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
End If
Next
ws.ShowAllData

 

[VBA Geek]

See how the below works for you. Assumes your data is in columns A:E

you need to updated this line :

Const mFol As String = "G:\depts\ZZZZ\"

to the folder where you want your txt files to be saved, dont forget to make it end with "\" as per above

Sub SaveTOCsv()
Dim Heade      As Variant
Dim u          As Long
Dim i          As Long
Dim inNum      As Variant
Dim iData      As Variant
Dim fData      As Variant
Dim sData      As Variant
Dim FF         As Integer
Const mFol     As String = "G:\depts\ZZZZ\"
Const Delim    As String = "^^"
Const DelimTxt As String = "|"
Heade = Range("A1:E1")
i = Range("E" & Rows.Count).End(xlUp).Row
inNum = Range("E2:E" & i)
inNum = UniqInv(inNum)
iData = Range("A2:E" & i).Value
ReDim fData(0 To UBound(iData) - 1)
For i = LBound(iData, 1) To UBound(iData, 1)
    fData(i - 1) = Delim & iData(i, 1) & Delim & iData(i, 2) & Delim & iData(i, 3) & Delim & iData(i, 4) & Delim & iData(i, 5) & Delim
Next

For i = LBound(inNum, 1) To UBound(inNum, 1)
    FF = VBA.FreeFile
    sData = Filter(fData, Delim & inNum(i) & Delim, True, vbTextCompare)
    Open mFol & inNum(i) & ".txt" For Output As #FF
    Print #FF, Heade(1, 1) & DelimTxt & Heade(1, 2) & DelimTxt & Heade(1, 3) & DelimTxt & Heade(1, 4)
        For u = LBound(sData) To UBound(sData)
            Print #FF, Join(Split(Mid(sData(u), 1, InStrRev(sData(u), Delim, Len(sData(u)) - 3) - 1), Delim), DelimTxt)
        Next
    Close #FF
Next
MsgBox "Txt Files succesfully created...."
End Sub



Function UniqInv(V As Variant) As Variant
    Dim D  As Object
    Set D = CreateObject("Scripting.Dictionary")
    Dim i  As Long
    For i = LBound(V, 1) To UBound(V, 1)
        If Not D.Exists(V(i, 1)) Then
            D.Add V(i, 1), V(i, 1)
        End If
    Next
    UniqInv = D.Keys
    Set D = Nothing
End Function