Can the filter sheets be save as a different workbook

October 7, 2013 at 04:02:59
Specs: Windows 7

Option Explicit

Private Sub till()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names for worksheets)
Set rngStart = Worksheets("Sheet1").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet1").Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with names
For Each rngCell In Range(rngStart, rngEnd)
'get name
strWsName = rngCell.Text
'exclude the main inelligible names
If strWsName <> "" And InStr(1, strWsName, "/") = 0 _
And InStr(1, strWsName, "\") = 0 And InStr(1, strWsName, "?") = 0 _
And InStr(1, strWsName, "*") = 0 And InStr(1, strWsName, "[") = 0 _
And InStr(1, strWsName, "]") = 0 Then
'test if worksheet exists
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy row to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp).Offset(1, 0)
rngCell.EntireRow.Copy
rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
Else
'name not valid - warn user - but ignore empty cells
If strWsName <> "" Then
MsgBox strWsName & " is not a valid worksheet name", vbOKOnly, _
"Worksheet Names"
End If
End If
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWindow.SmallScroll Down:=-51
Range("M17").Select
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("ABOND").Select
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Sheets("AFWA").Select
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Application.CutCopyMode = False
End Sub


See More: Can the filter sheets be save as a different workbook

Report •


#1
October 7, 2013 at 08:09:18
There are 2 issues with your post:

1 - You posted some code, but you didn't actually ask a question. If you want us to help you, you should try to make it as easy as you can for us to figure out what you are doing and what you want done.

You should post something like...

"The following code is used to (tell us what the code does). What I am trying to do is (tell us what you are having a problem with).

2 - Please click on the following line and read the instructions on how to post VBA code in this fourm. By following the instructions found via that link, the code will be formatted in a manner that will make it much easier for us to read. Of course, that assumes that you used indents when you wrote the code.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •
Related Solutions


Ask Question