update code split data into multiple sheets based on inputbox

A

abdo meghari

Active Member
Joined
Aug 3, 2021
Messages
465
Office Version
  1. 2019
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?
VBA Code: 
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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
abdo meghari said:
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
Click to expand...

Could you exemplify it?
And what would be the name of the new sheet?
 
Upvote 0
this is the orginal data in sheet1
sp.xlsm
ABCDEFGH
1BRANDCODETYPEDATEORIGINQTYPRICETOTAL
21200R20ID12G5801/1/2021THI100.00456.0045,600.00
31200R20ID12G5801/2/2021THI20.00340.006,800.00
41200R20ID14G5801/3/2021INDO12.00400.004,800.00
51200R20ID14G5801/4/2021INDO12.00410.004,920.00
61400R20ID16VSJ1/5/2021THI20.00820.0016,400.00
71400R20ID17R1791/6/2021THI10.00800.008,000.00
SHEET1
Cell Formulas
RangeFormula
H3:H7H3=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
ABCDEFGHI
1ITEMBRANDCODETYPEDATEORIGINQTYPRICETOTAL
211200R20ID12G5801/1/2021THI100.00456.0045,600.00
321200R20ID12G5801/2/2021THI20.00340.006,800.00
1200R20 G580 THI
Cell Formulas
RangeFormula
I3I3=G3*H3




sp.xlsm
ABCDEFGHI
1ITEMBRANDCODETYPEDATEORIGINQTYPRICETOTAL
211200R20ID14G5801/3/2021INDO12.00400.004,800.00
321200R20ID14G5801/4/2021INDO12.00410.004,920.00
1200R20 G580 INDO
Cell Formulas
RangeFormula
I2:I3I2=G2*H2



sp.xlsm
ABCDEFGHI
1ITEMBRANDCODETYPEDATEORIGINQTYPRICETOTAL
211400R20ID16VSJ1/5/2021THI20.00820.0016,400.00
1400R20 VSJ THI
Cell Formulas
RangeFormula
I2I2=G2*H2



sp.xlsm
ABCDEFGHI
1ITEMBRANDCODETYPEDATEORIGINQTYPRICETOTAL
211400R20ID17R1791/6/2021THI10.00800.008,000.00
1400R20 R179 THI
Cell Formulas
RangeFormula
I2I2=G2*H2


I hope this help .
 
Upvote 0
Try this:

VBA Code: 
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
 
Upvote 0
thanks but it gives error " method range of object worksheet failed" in this line
VBA Code: 
 ws.Range(Title).AutoFilter Field:=cols(c), Criteria1:=k(c)
 
Upvote 0
My fault, I did not update that data.
Use like this:

VBA Code: 
ws.Range("A1").AutoFilter Field:=cols(c), Criteria1:=k(c)
 
Upvote 0
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
VBA Code: 
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = nom
when run macro repeatedly .
 
Upvote 0
Again my fault.
Try the following. I corrected the part to name the sheet.

VBA Code: 
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
 
Upvote 0
Solution
sometimes works well and somtimes gives" automation error" in this line
VBA Code: 
ws.Range("A1:A" & lr).EntireRow.Copy Sheets(nom).Range("A1")
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
134
Scifo
S
S
  • Solved
VBA Parse Data. (do not want title to copy over Every time)
Replies
2
Views
492
Scifo
S
S
  • Question
VBA code_How to keep in Excel header row included when splitting worksheet to separate worksheets
Replies
1
Views
695
rlv01
R
S
  • Solved
Parse Data - Paste Range to new sheets as values only.
Replies
9
Views
599
Scifo
S
M
  • Question
Need to keep data only for one cell value.
Replies
0
Views
459
MDMitch
M

Forum statistics

Threads
1,215,467
Messages
6,124,984
Members
449,201
Latest member
Lunzwe73

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top