Add input boxes to VBA code

[mountainman88]

I have found some code that does exactly what I need except I'd like the below constants to be based on a user input box instead of embeeded in the code:

Const FirstC As String = "A" '1st column

Const LastC As String = "AG" 'last column

Const sCol As String = "O" '<<< Criteria in Column O

Const shN As String = "journals" '<<< Source Sheet

Full code here:

Sub Split_Sht_in_Separate_Shts()

'### 17-03-2019 ###

Const FirstC As String = "A" '1st column

Const LastC As String = "AG" 'last column

Const sCol As String = "O" '<<< Criteria in Column B

Const shN As String = "journals" '<<< Source Sheet

Dim ws As Worksheet, ws1 As Worksheet

Set ws = Sheets(shN)

Dim rng As Range

Dim r As Long, c As Long, x As Long, r1 As Long

Application.ScreenUpdating = False

r = ws.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2

Set rng = ws.Range(ws.Cells(1, FirstC), ws.Cells(r, LastC))

ws.Range(sCol & ":" & sCol).Copy

ws.Cells(1, c).PasteSpecial xlValues

Application.CutCopyMode = False

ws.Cells(1, c).Resize(r).RemoveDuplicates Columns:=1, Header:=xlYes

r1 = ws.Cells(Rows.Count, c).End(xlUp).Row

ws.Cells(1, c).Resize(r1).Sort Key1:=ws.Cells(1, c), Header:=xlYes

ws.AutoFilterMode = False

Application.DisplayAlerts = False

For x = 2 To r1

For Each ws1 In Sheets

If ws1.Name = ws.Cells(x, c) Then ws1.Delete

Next

Next

Application.DisplayAlerts = True

For x = 2 To r1

ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=ws.Cells(x, c)

Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))

ws1.Name = ws.Cells(x, c).Value

rng.SpecialCells(xlCellTypeVisible).Copy

Range("A1").PasteSpecial Paste:=xlPasteFormats

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

Range("A1").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

Next x

With ws

.AutoFilterMode = False

.Cells(1, c).Resize(r).ClearContents

.Activate

.Range("A1").Select

End With

Application.ScreenUpdating = True

End Sub

Thanks in advance!

 

[mountainman88]

if code could be added to create a filter in each tab that would be awesome!

 

[mumps]

This should take care of the input boxes:

Sub Split_Sht_in_Separate_Shts()
    '### 17-03-2019 ###
    Dim FirstC As String, LastC As String, sCol As String, shN As String
    Dim ws As Worksheet, ws1 As Worksheet, rng As Range, r As Long, c As Long, x As Long, r1 As Long
    FirstC = InputBox("Enter the first column letter.")
    LastC = InputBox("Enter the last column letter.")
    sCol = InputBox("Enter the criteria for column B.")
    shN = InputBox("Enter the source sheet name.")
    Set ws = Sheets(shN)
    Application.ScreenUpdating = False
    r = ws.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2
    Set rng = ws.Range(ws.Cells(1, FirstC), ws.Cells(r, LastC))
    ws.Range(sCol & ":" & sCol).Copy
    ws.Cells(1, c).PasteSpecial xlValues
    Application.CutCopyMode = False
    ws.Cells(1, c).Resize(r).RemoveDuplicates Columns:=1, Header:=xlYes
    r1 = ws.Cells(Rows.Count, c).End(xlUp).Row
    ws.Cells(1, c).Resize(r1).Sort Key1:=ws.Cells(1, c), Header:=xlYes
    ws.AutoFilterMode = False
    Application.DisplayAlerts = False
    For x = 2 To r1
        For Each ws1 In Sheets
            If ws1.Name = ws.Cells(x, c) Then ws1.Delete
        Next
    Next x
    Application.DisplayAlerts = True
    For x = 2 To r1
        ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=ws.Cells(x, c)
        Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws1.Name = ws.Cells(x, c).Value
        rng.SpecialCells(xlCellTypeVisible).Copy
        Range("A1").PasteSpecial Paste:=xlPasteFormats
        Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        Range("A1").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    Next x
    With ws
        .AutoFilterMode = False
        .Cells(1, c).Resize(r).ClearContents
        .Activate
        .Range("A1").Select
    End With
    Application.ScreenUpdating = True
End Sub

Do you want to autofilter each sheet after some of the sheets have been deleted? If so, please explain in detail which column the filter is based on and what the filter criteria are. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[mountainman88]

Thanks that worked, I dont need the data filtered to any particular view. I just need a filter ready for the column range specified in the inputs, on each tab so the data can be filtered.

thanks

 

[mumps]

Try:

For x = 2 To r1
        For Each ws1 In Sheets
            If ws1.Name = ws.Cells(x, c) Then ws1.Delete
            ws1.Range("A1").AutoFilter
        Next
    Next x