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]

the cause of the error is due to the headers you placed at the top - they are text and not numbers. I have now adjusted the code to start reading from the second row

Sub subsetTestAuto_2()
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 = 2 To j
If InStr(1, dn, Cells(dd, 1), vbTextCompare) = 0 Then
dn = dn & "|" & Cells(dd, 1)
c = Cells(dd, 1)
For z = 2 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 = 2 To j
If Cells(p, 1) = c And Str(Cells(p, 2)) = Str(d(i)) Then
If id = "" Then id = Cells(p, 3) Else id = id & vbNewLine & Cells(p, 3)
p1 = Cells(p, 2) * 100
hz = Split(p1, ".", , vbTextCompare)
End If
Next p

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

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

I know i am very dumb . Thanks a lot for your resolution.
It works well, except for the combination of CODE 2023 and 100.00%, the TXT file is not generating.

 

[Rakesh99932]

I know i am very dumb . Thanks a lot for your resolution.
It works well, except for the combination of CODE 2023 and 100.00%, the TXT file is not generating.

Could you please help.

 

[yinkajewole]

have this

Sub SubsetCode()
Dim cod() As String, folder$, fol As FileDialog
For az = 2 To ActiveSheet.Cells(1048576, 1).End(xlUp).Row
If InStr(1, cd, Cells(az, 1)) = 0 Then
If cd = "" Then cd = Cells(az, 1) Else cd = cd & "-|" & Cells(az, 1)
End If
Next az
cod = Split(cd, "-|", , vbTextCompare)
Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
For zd = 0 To UBound(cod)
SubsetTestss cod(zd), folder
Next
End Sub
Sub SubsetTestss(s$, folder$)
Dim c&, j, id$, dd, d() As String, sel As Boolean, z, b$, i&, p&
Dim h() As String, t&, per$
If s <> "" Then c = s Else Exit Sub
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For z = 2 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
b = Replace(Replace(b, "||", "~"), "|", "")
d = Split(b, "~", , vbTextCompare)
For i = 0 To UBound(d)
For p = 2 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 & "cid_" & c & per & "_" & Format(Date, "mmdd") & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = ""
Next i
End Sub

 

[Rakesh99932]

have this

Sub SubsetCode()
Dim cod() As String, folder$, fol As FileDialog
For az = 2 To ActiveSheet.Cells(1048576, 1).End(xlUp).Row
If InStr(1, cd, Cells(az, 1)) = 0 Then
If cd = "" Then cd = Cells(az, 1) Else cd = cd & "-|" & Cells(az, 1)
End If
Next az
cod = Split(cd, "-|", , vbTextCompare)
Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
For zd = 0 To UBound(cod)
SubsetTestss cod(zd), folder
Next
End Sub
Sub SubsetTestss(s$, folder$)
Dim c&, j, id$, dd, d() As String, sel As Boolean, z, b$, i&, p&
Dim h() As String, t&, per$
If s <> "" Then c = s Else Exit Sub
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For z = 2 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
b = Replace(Replace(b, "||", "~"), "|", "")
d = Split(b, "~", , vbTextCompare)
For i = 0 To UBound(d)
For p = 2 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 & "cid_" & c & per & "_" & Format(Date, "mmdd") & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = ""
Next i
End Sub

Wow, this code resolved the issue. Thank u so much for your help. Appreciate it.!!!

 

[Rakesh99932]

have this

Sub SubsetCode()
Dim cod() As String, folder$, fol As FileDialog
For az = 2 To ActiveSheet.Cells(1048576, 1).End(xlUp).Row
If InStr(1, cd, Cells(az, 1)) = 0 Then
If cd = "" Then cd = Cells(az, 1) Else cd = cd & "-|" & Cells(az, 1)
End If
Next az
cod = Split(cd, "-|", , vbTextCompare)
Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
For zd = 0 To UBound(cod)
SubsetTestss cod(zd), folder
Next
End Sub
Sub SubsetTestss(s$, folder$)
Dim c&, j, id$, dd, d() As String, sel As Boolean, z, b$, i&, p&
Dim h() As String, t&, per$
If s <> "" Then c = s Else Exit Sub
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For z = 2 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
b = Replace(Replace(b, "||", "~"), "|", "")
d = Split(b, "~", , vbTextCompare)
For i = 0 To UBound(d)
For p = 2 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 & "cid_" & c & per & "_" & Format(Date, "mmdd") & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = ""
Next i
End Sub

Can you also please update to show (this is optional)
1. The count of the text files generated at the end?
2. While selecting the destination folder, can we rename the folder selection pop up as "Select folder to save Subsets"?

 

[yinkajewole]

try this:

Public n As Variant ' <==this should be at the top of the module
Sub SubsetCode()
Dim cod() As String, folder$, fol As FileDialog
For az = 2 To ActiveSheet.Cells(1048576, 1).End(xlUp).Row
If InStr(1, cd, Cells(az, 1)) = 0 Then
If cd = "" Then cd = Cells(az, 1) Else cd = cd & "-|" & Cells(az, 1)
End If
Next az
cod = Split(cd, "-|", , vbTextCompare)
Set fol = Application.FileDialog(msoFileDialogFolderPicker)
fol.AllowMultiSelect = False
fol.Title = "Select folder to save Subsets"
sel = fol.Show
If sel Then folder = fol.SelectedItems(1) & "\" Else Exit Sub
n = 0
For zd = 0 To UBound(cod)
SubsetTestss cod(zd), folder
Next
MsgBox n & " files generated"
End Sub
Sub SubsetTestss(s$, folder$)
Dim c&, j, id$, dd, d() As String, sel As Boolean, z, b$, i&, p&
Dim h() As String, t&, per$
If s <> "" Then c = s Else Exit Sub
j = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For z = 2 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
b = Replace(Replace(b, "||", "~"), "|", "")
d = Split(b, "~", , vbTextCompare)
For i = 0 To UBound(d)
For p = 2 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 & "cid_" & c & per & "_" & Format(Date, "mmdd") & ".txt" For Output As #1
Print #1, id;
n = n + 1
Close #1
id = "": per = ""
Next i
End Sub