Create .TXT Subsets based on existing Excel data using VBA Macro

[Rakesh99932]

Hello Guys,
I need to create Subsets for the data which I have, which is dynamic, using Excel VBA.
I have data in the form of table, whose column headings are Code, % & Transaction ID as the below table.

Code​	%​	Transaction ID​
1001​	42.10%​	455152​
1001​	42.10%​	455153​
1001​	42.10%​	455154​
1001​	55.10%​	455155​
1001​	55.10%​	455156​
1001​	55.10%​	455157​
1002​	66.40%​	455158​
1002​	66.40%​	455159​
1002​	66.40%​	455160​
1002​	66.40%​	455161​
1002​	85.70%​	455162​
1003​	85.70%​	455163​
1003​	85.70%​	455164​
1003​	85.70%​	455165​
1003​	85.70%​	455166​
1004​	95.60%​	455167​
1004​	95.60%​	455168​
1004​	95.60%​	455169​
1004​	95.60%​	455170​
1004​	95.60%​	455171​

I need to create subsets in .txt file which only shows Transaction ID's in it based on the combinations between Code and %.

For example, if I filter Code 1001, I can see 42.10% & 55.10%. For the first combination of code 1001 & 42.10%, the transaction ID’s only should be copied to a .txt file and this .txt file should be saved with the naming convection using “TXT_Code%_ddmm” format.

Example of the combinations:

Example 1:

Code​	%​	Transaction ID​
1001​	42.10%​	455152​
1001​	42.10%​	455153​
1001​	42.10%​	455154​

In the above table, i have filtered 1001 Code and 42.10%. I need transaction Id’s only should be copied to a new .txt file, and its naming convection should be as “TXT_1001421_ddmm” format and save this .Txt file in the folder.

Example 2:

Code​	%​	Transaction ID​
1001​	55.10%​	455155​
1001​	55.10%​	455156​
1001​	55.10%​	455157​

In the above table, i have filtered 1001 Code and 55.10%. I need transaction Id’s only should be copied to a new .txt file, and its naming convection should be as “TXT_1001551_ddmm” format and save this file in the folder.

The data is always dynamic and the combinations are also dynamic.

Request your kind help in this matter, as this will save lo of time for the huge data I have.

Thank you for your help in Advance.

 

[Rakesh99932]

this should take all the codes

Sub subsetTestAuto()
Dim s$, c&, j, id$, dd, d() As String, sel As Boolean, folder$, fol As FileDialog, z, b$, i&, p&
Dim h() As String, t&, per$
dd = 1
Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
Do Until Cells(dd, 1) = ""
c = Cells(dd, 1)
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For z = 1 To j
If Cells(z, 1) = c Then
If InStr(1, b, Cells(z, 2)) > 0 Then
Else
If b = "" Then b = Cells(z, 2) Else b = b & "|" & Cells(z, 2)
End If
End If
Next z
d = Split(b, "|", , vbTextCompare)
For i = 0 To UBound(d)
For p = 1 To j
If Cells(p, 1) = c And Cells(p, 2) = d(i) Then
If id = "" Then id = Cells(p, 3) Else id = id & vbNewLine & Cells(p, 3)
h = Split(CDec(Cells(p, 2)) * 100, ".", , vbTextCompare)
End If
Next p

For t = 0 To UBound(h)
If IsNumeric(h(t)) Then
If per = "" Then per = h(t) Else per = per & h(t)
End If
Next

Open folder & "TXT_" & c & per & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = ""
Next i
dd = dd + 1
Loop
End Sub

Yes all codes in that table. I tried the new code, but not able to get the results.

 

[yinkajewole]

what was the result?

 

[yinkajewole]

Sub subsetTestAuto()
Dim s$, c&, j, id$, dd, d() As String, sel As Boolean, folder$, fol As FileDialog, z, b$, i&, p&
Dim h() As String, t&, per$

Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For dd = 1 To j
If InStr(1, dn, Cells(dd, 1), vbTextCompare) = 0 Then
dn = dn & "|" & Cells(dd, 1)
c = Cells(dd, 1)
For z = 1 To j
If Cells(z, 1) = c Then
If InStr(1, b, Cells(z, 2)) > 0 Then
Else
If b = "" Then b = Cells(z, 2) Else b = b & "|" & Cells(z, 2)
End If
End If
Next z
d = Split(b, "|", , vbTextCompare)
For i = 0 To UBound(d)
For p = 1 To j
If Cells(p, 1) = c And Cells(p, 2) = d(i) Then
If id = "" Then id = Cells(p, 3) Else id = id & vbNewLine & Cells(p, 3)

h = Split(CDec(Cells(p, 2)) * 100, ".", , vbTextCompare)
End If
Next p

For t = 0 To UBound(h)
If IsNumeric(h(t)) Then
If per = "" Then per = h(t) Else per = per & h(t)
End If
Next

Open folder & "TXT_" & c & per & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = "": b = ""
Next i
End If
Next dd

 

[Rakesh99932]

After I select the destination folder, the txt files are not being saved. I mean, once i give folder path, i dont see anything running.

 

[RoryA]

Cross-posted here.

Please read the forum rules on cross-posting and follow them in future. Thanks.

 

[Rakesh99932]

Sub subsetTestAuto()
Dim s$, c&, j, id$, dd, d() As String, sel As Boolean, folder$, fol As FileDialog, z, b$, i&, p&
Dim h() As String, t&, per$

Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For dd = 1 To j
If InStr(1, dn, Cells(dd, 1), vbTextCompare) = 0 Then
dn = dn & "|" & Cells(dd, 1)
c = Cells(dd, 1)
For z = 1 To j
If Cells(z, 1) = c Then
If InStr(1, b, Cells(z, 2)) > 0 Then
Else
If b = "" Then b = Cells(z, 2) Else b = b & "|" & Cells(z, 2)
End If
End If
Next z
d = Split(b, "|", , vbTextCompare)
For i = 0 To UBound(d)
For p = 1 To j
If Cells(p, 1) = c And Cells(p, 2) = d(i) Then
If id = "" Then id = Cells(p, 3) Else id = id & vbNewLine & Cells(p, 3)

h = Split(CDec(Cells(p, 2)) * 100, ".", , vbTextCompare)
End If
Next p

For t = 0 To UBound(h)
If IsNumeric(h(t)) Then
If per = "" Then per = h(t) Else per = per & h(t)
End If
Next

Open folder & "TXT_" & c & per & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = "": b = ""
Next i
End If
Next dd

Cross-posted here.

Please read the forum rules on cross-posting and follow them in future. Thanks.

Sure, Will delete that posting.

 

[Norie]

Try this, it should create text files with the data separated by commas.

Option Explicit

Sub CreateSubSets()
Dim arrData As Variant
Dim arrTransactions As Variant
Dim dicSubSets As Object
Dim strFileName As String
Dim strPath As String
Dim cnt As Long
Dim FF As Long
Dim idxCol As Long
Dim idxRow As Long
Dim ky As Variant

    strPath = "C:\Test\"
    
    arrData = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion
    
    Set dicSubSets = CreateObject("Scripting.Dictionary")
    
    ' split data into subsets
    
    For idxRow = 2 To UBound(arrData, 1)
        
        ky = arrData(idxRow, 1) & "-" & arrData(idxRow, 2)
        
        If dicSubSets.Exists(ky) Then
            arrTransactions = dicSubSets(ky)
            cnt = UBound(arrTransactions) + 1
            ReDim Preserve arrTransactions(cnt)
        Else
            ReDim arrTransactions(0)
            cnt = 0
        End If
    
        arrTransactions(cnt) = arrData(idxRow, 3)
    
        dicSubSets(ky) = arrTransactions
        
    Next idxRow
    
    ' write each subset out to text file
    For Each ky In dicSubSets.Keys
    
        strFileName = "TXT" & Replace(Replace(Replace(ky, "%", ""), "-", ""), ".", "") & ".txt"
        
        FF = FreeFile
        
        Open strPath & strFileName For Output As #FF
        
            arrTransactions = dicSubSets(ky)
            
            Print #FF, Join(Array("Code", "%", "TransactionID"), ",")
            For idxRow = LBound(arrTransactions) To UBound(arrTransactions)
                Print #FF, Join(Array(Split(ky, "-")(0), Split(ky, "-")(1), arrTransactions(idxRow)), ",")
            Next idxRow
            
        Close #FF
        
    Next ky
    
End Sub

 

[Rakesh99932]

Try this, it should create text files with the data separated by commas.

Option Explicit

Sub CreateSubSets()
Dim arrData As Variant
Dim arrTransactions As Variant
Dim dicSubSets As Object
Dim strFileName As String
Dim strPath As String
Dim cnt As Long
Dim FF As Long
Dim idxCol As Long
Dim idxRow As Long
Dim ky As Variant

    strPath = "C:\Test\"
   
    arrData = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion
   
    Set dicSubSets = CreateObject("Scripting.Dictionary")
   
    ' split data into subsets
   
    For idxRow = 2 To UBound(arrData, 1)
       
        ky = arrData(idxRow, 1) & "-" & arrData(idxRow, 2)
       
        If dicSubSets.Exists(ky) Then
            arrTransactions = dicSubSets(ky)
            cnt = UBound(arrTransactions) + 1
            ReDim Preserve arrTransactions(cnt)
        Else
            ReDim arrTransactions(0)
            cnt = 0
        End If
   
        arrTransactions(cnt) = arrData(idxRow, 3)
   
        dicSubSets(ky) = arrTransactions
       
    Next idxRow
   
    ' write each subset out to text file
    For Each ky In dicSubSets.Keys
   
        strFileName = "TXT" & Replace(Replace(Replace(ky, "%", ""), "-", ""), ".", "") & ".txt"
       
        FF = FreeFile
       
        Open strPath & strFileName For Output As #FF
       
            arrTransactions = dicSubSets(ky)
           
            Print #FF, Join(Array("Code", "%", "TransactionID"), ",")
            For idxRow = LBound(arrTransactions) To UBound(arrTransactions)
                Print #FF, Join(Array(Split(ky, "-")(0), Split(ky, "-")(1), arrTransactions(idxRow)), ",")
            Next idxRow
           
        Close #FF
       
    Next ky
   
End Sub

Thank You Norie.
I need only Transaction ID's in the TXT file without the column header.
Infact, The solution provided by yinkajewole is working great with manual "code" entry. But am also looking for auto creating subsets without manual entry.

 

[Norie]

Change this,

            Print #FF, Join(Array("Code", "%", "TransactionID"), ",")
            For idxRow = LBound(arrTransactions) To UBound(arrTransactions)
                Print #FF, Join(Array(Split(ky, "-")(0), Split(ky, "-")(1), arrTransactions(idxRow)), ",")
            Next idxRow

to this.

            For idxRow = LBound(arrTransactions) To UBound(arrTransactions)
                Print #FF, arrTransactions(idxRow)
            Next idxRow

 

[Rakesh99932]

Change this,

            Print #FF, Join(Array("Code", "%", "TransactionID"), ",")
            For idxRow = LBound(arrTransactions) To UBound(arrTransactions)
                Print #FF, Join(Array(Split(ky, "-")(0), Split(ky, "-")(1), arrTransactions(idxRow)), ",")
            Next idxRow

to this.

            For idxRow = LBound(arrTransactions) To UBound(arrTransactions)
                Print #FF, arrTransactions(idxRow)
            Next idxRow

It is working like wonder for me. !! Thank you.
Couple of requests.
1. Could you please modify the Folder path using a dialog box, so that i can get the outcome in the folder I want.
2. If the % is 100.00 %, then the outcome file name is not showing those 2 zero's after 1.
For Ex: if the code and % are 3020 and 100.00% respectively, the file name should have TXT_3020100