I need to add an Input Box

  • Thread starter charles.w.price
  • Start date
C

charles.w.price

I need to add an InputBox to the following script to ask me which
column to use to separate the data. Does anyone know how to add the
InputBox.

Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long



Set ws1 = Sheets("Sheet1") '<<< Change

'Tip : You can also use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1").CurrentRegion '<<< Change



With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With



With ws1
rng.Columns(3).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True

'This example filter on the first column in the range (change
this if needed)
'You see that the last two columns of the worksheet are used
to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you
use the columns)


Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value



For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & "
manually"
Err.Clear
End If
On Error GoTo 0
 
R

Ron de Bruin

Try this

Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim num As Long

Set ws1 = Sheets("Sheet1") '<<< Change
'Tip : You can also use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

num = Application.InputBox(prompt:="Type a column number", Type:=1)
If num > 0 And num < ws1.Range("A1").CurrentRegion.Columns.Count Then

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(num).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change this if needed)
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use the columns)

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End If
End Sub
 
R

Ron de Bruin

< ws1.Range("A1").CurrentRegion.Columns.Count

Must be

<= ws1.Range("A1").CurrentRegion.Columns.Count
 
C

charles.w.price

< ws1.Range("A1").CurrentRegion.Columns.Count

Must be

<= ws1.Range("A1").CurrentRegion.Columns.Count

Thank a lot Ron, That is great. What would I need to change if I
wanted to enter Column "C" instead of Column "3"?
 
R

Ron de Bruin

This is possible but you need a lot of error checking
Why not run it for the column where the activecell is ?
Is that a option ?
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top