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]

Hi,

Request your help me in providing solution to this. This would help me a lot.

 

[yinkajewole]

I've made some adjustments. Try this and give me a feedback

Sub subsetTestAuto()
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 Str(Cells(p, 2)) = Str(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 & " " & c & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = "": b = ""
Next i
End If
Next dd
End Sub

 

[Rakesh99932]

I've made some adjustments. Try this and give me a feedback

Sub subsetTestAuto()
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 Str(Cells(p, 2)) = Str(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 & " " & c & ".txt" For Output As #1
Print #1, id;
Close #1
id = "": per = "": b = ""
Next i
End If
Next dd
End Sub

Hi yinkajewole,
Thank you for looking into this. I am getting the same error (Type Mismatch) at the line

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

 

[yinkajewole]

This is serious!
I do not get the error. However, I've made little modifications.

Sub subsetTestAuto()
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 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

If the above code still do not work then Try it with another file or you will have to send me the actual file if you don't mind.

 

[Rakesh99932]

This is serious!
I do not get the error. However, I've made little modifications.

Sub subsetTestAuto()
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 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

If the above code still do not work then Try it with another file or you will have to send me the actual file if you don't mind.

Thank u so much for your effort to help me. But still same error at this line

If Cells(p, 1) = c And Str(Cells(p, 2)) = Str(d(i)) Then

So sorry for bothering.

 

[yinkajewole]

it's possible that one of the cells in the percentage column may not be figures

 

[Rakesh99932]

it's possible that one of the cells in the percentage column may not be figures

All the cells in the percentage column are in figures. Not sure why still the error

 

[yinkajewole]

Can you send the file if i can debug the issue?

 

[Rakesh99932]

Can you send the file if i can debug the issue?

Sure, But i cannot find option here to attach the file. Any idea?

 

[yinkajewole]

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