update code split data into multiple sheets based on inputbox

[abdo meghari]

hello
I have this code splits data into multple sheets based on write column number into input box . I would mod this code by making more flexible to select multiple columns together for instance I would split data based on three columns together when write in inputbox like this 1,3,5 . is that possible guys?

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

Application.ScreenUpdating = False
vcol = Application.InputBox(Prompt:=" which column should  filter?", title:="column filter", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

I would mod this code by making more flexible to select multiple columns together for instance I would split data based on three columns together when write in inputbox like this 1,3,5

Could you exemplify it?
And what would be the name of the new sheet?

 

[abdo meghari]

this is the orginal data in sheet1

sp.xlsm
	A	B	C	D	E	F	G	H
1	BRAND	CODE	TYPE	DATE	ORIGIN	QTY	PRICE	TOTAL
2	1200R20	ID12	G580	1/1/2021	THI	100.00	456.00	45,600.00
3	1200R20	ID12	G580	1/2/2021	THI	20.00	340.00	6,800.00
4	1200R20	ID14	G580	1/3/2021	INDO	12.00	400.00	4,800.00
5	1200R20	ID14	G580	1/4/2021	INDO	12.00	410.00	4,920.00
6	1400R20	ID16	VSJ	1/5/2021	THI	20.00	820.00	16,400.00
7	1400R20	ID17	R179	1/6/2021	THI	10.00	800.00	8,000.00
SHEET1

Cell Formulas
Range	Formula
H3:H7	H3	=F3*G3

expected result based on column A,C,E also should rename the sheets when create based on column A,C,E and if I add new data or changes in sheet1 then should update the others sheets have been created with ignore the formula in last column .

sp.xlsm
	A	B	C	D	E	F	G	H	I
1	ITEM	BRAND	CODE	TYPE	DATE	ORIGIN	QTY	PRICE	TOTAL
2	1	1200R20	ID12	G580	1/1/2021	THI	100.00	456.00	45,600.00
3	2	1200R20	ID12	G580	1/2/2021	THI	20.00	340.00	6,800.00
1200R20 G580 THI

Cell Formulas
Range	Formula
I3	I3	=G3*H3

sp.xlsm
	A	B	C	D	E	F	G	H	I
1	ITEM	BRAND	CODE	TYPE	DATE	ORIGIN	QTY	PRICE	TOTAL
2	1	1200R20	ID14	G580	1/3/2021	INDO	12.00	400.00	4,800.00
3	2	1200R20	ID14	G580	1/4/2021	INDO	12.00	410.00	4,920.00
1200R20 G580 INDO

Cell Formulas
Range	Formula
I2:I3	I2	=G2*H2

sp.xlsm
	A	B	C	D	E	F	G	H	I
1	ITEM	BRAND	CODE	TYPE	DATE	ORIGIN	QTY	PRICE	TOTAL
2	1	1400R20	ID16	VSJ	1/5/2021	THI	20.00	820.00	16,400.00
1400R20 VSJ THI

Cell Formulas
Range	Formula
I2	I2	=G2*H2

sp.xlsm
	A	B	C	D	E	F	G	H	I
1	ITEM	BRAND	CODE	TYPE	DATE	ORIGIN	QTY	PRICE	TOTAL
2	1	1400R20	ID17	R179	1/6/2021	THI	10.00	800.00	8,000.00
1400R20 R179 THI

Cell Formulas
Range	Formula
I2	I2	=G2*H2

I hope this help .

 

[DanteAmor]

Try this:

Sub parse_data()
  Dim i As Long, lr As Long
  Dim vcol As Variant, ky As Variant, cols As Variant, c As Variant, k As Variant
  Dim ws As Worksheet
  Dim cad As String, nom As String
  Dim dic As Object
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  vcol = Application.InputBox(Prompt:="Which columns should filter?", _
         Title:="column filter", Default:="1,3,5")
  Set ws = ActiveSheet
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  If ws.AutoFilterMode Then ws.AutoFilterMode = False
  
  cols = Split(vcol, ",")
  c = Val(cols(0))
  lr = ws.Cells(ws.Rows.Count, c).End(xlUp).Row
  
  For i = 2 To ws.Cells(ws.Rows.Count, c).End(xlUp).Row
    cad = ""
    nom = ""
    For Each c In cols
      cad = cad & ws.Cells(i, Val(c)).Value & "|"
      nom = nom & ws.Cells(i, Val(c)).Value & " "
    Next
    If cad <> "" Then
      cad = Left(cad, Len(cad) - 1)
      nom = Left(nom, Len(nom) - 1)
      dic(cad) = nom
    End If
  Next
  
  For Each ky In dic.keys
    k = Split(ky, "|")
    nom = dic(ky)
    For c = 0 To UBound(k)
      ws.Range(Title).AutoFilter Field:=cols(c), Criteria1:=k(c)
    Next
    On Error Resume Next
      Sheets(k(c)).Delete
    On Error GoTo 0
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = nom
    ws.Range("A1:A" & lr).EntireRow.Copy Sheets(nom).Range("A1")
  Next
  ws.AutoFilterMode = False
  ws.Activate
  Application.ScreenUpdating = True
End Sub

 

[abdo meghari]

thanks but it gives error " method range of object worksheet failed" in this line

 ws.Range(Title).AutoFilter Field:=cols(c), Criteria1:=k(c)

 

[DanteAmor]

My fault, I did not update that data.
Use like this:

ws.Range("A1").AutoFilter Field:=cols(c), Criteria1:=k(c)

 

[abdo meghari]

thank again , but I accept from the code should update the data in sheets have ever splited when changes or add new data in sheet1
but it gives error in this line

Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = nom

when run macro repeatedly .

 

[DanteAmor]

Again my fault.
Try the following. I corrected the part to name the sheet.

Sub parse_data()
  Dim i As Long, lr As Long
  Dim vcol As Variant, ky As Variant, cols As Variant, c As Variant, k As Variant
  Dim ws As Worksheet
  Dim cad As String, nom As String
  Dim dic As Object
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  vcol = Application.InputBox(Prompt:="Which columns should filter?", _
         Title:="column filter", Default:="1,3,5")
  Set ws = ActiveSheet
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  If ws.AutoFilterMode Then ws.AutoFilterMode = False
  
  cols = Split(vcol, ",")
  c = Val(cols(0))
  lr = ws.Cells(ws.Rows.Count, c).End(xlUp).Row
  
  For i = 2 To ws.Cells(ws.Rows.Count, c).End(xlUp).Row
    cad = ""
    nom = ""
    For Each c In cols
      cad = cad & ws.Cells(i, Val(c)).Value & "|"
      nom = nom & ws.Cells(i, Val(c)).Value & " "
    Next
    If cad <> "" Then
      cad = Left(cad, Len(cad) - 1)
      nom = Left(nom, Len(nom) - 1)
      dic(cad) = nom
    End If
  Next
  
  For Each ky In dic.keys
    k = Split(ky, "|")
    nom = dic(ky)
    For c = 0 To UBound(k)
      ws.Range("A1").AutoFilter Field:=cols(c), Criteria1:=k(c)
    Next
    On Error Resume Next
      Sheets(nom).Delete
    On Error GoTo 0
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = nom
    ws.Range("A1:A" & lr).EntireRow.Copy Sheets(nom).Range("A1")
  Next
  ws.AutoFilterMode = False
  ws.Activate
  Application.ScreenUpdating = True
End Sub

 

[abdo meghari]

sometimes works well and somtimes gives" automation error" in this line

ws.Range("A1:A" & lr).EntireRow.Copy Sheets(nom).Range("A1")

 

[DanteAmor]

Does the error message say something else?
You could share the data sample that you are testing with.
And what columns are you putting in the inputbox.