rey06
03-01-2016, 06:03 PM
Hi-
I have this code below which splits out a file based on distributor (column Z) onto new sheets and names the files based on what is in column Z. However, I came across one that has a "/" in it, which cannot be in the sheet name and causes an error. Was wondering if there is a way to add code to replace the slash (or any special character, if possible) with a space.
Also open to ideas to clean this up. :) I've kind of pieced it together from other codes I've found/asked for help with so it's kind of a mess. I'm not a VBA expert by any means.
Sub aSplitByDistributor()
Workbooks(1).Activate
Dim lastCol As Integer, LastRow As Long, x As Long
Dim rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim SheetNameArray, fn As WorksheetFunction
Dim CalcSetting As Integer
Dim newsht As Worksheet
Set fn = Application.WorksheetFunction
ActiveWorkbook.Worksheets("Flat File").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Flat File").Sort.SortFields.Add Key:=Range( _
"AR:AR"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Flat File").Sort
.SetRange Range("A:AT")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Application
CalcSetting = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With Sheets("Flat File")
Set rng = .UsedRange
Set Rng1 = Intersect(rng, .Range("Z:Z"))
lastCol = rng.Column + rng.Columns.Count - 1
.Range("Z:Z").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, lastCol + 2), Unique:=True
Set Rng2 = Intersect(.Columns(lastCol + 2).CurrentRegion, _
.Rows("2:" & Rows.Count))
ReDim SheetNameArray(1 To Rng2.Cells.Count)
SheetNameArray = fn.Transpose(Rng2)
.Columns(lastCol + 2).Clear
For x = LBound(SheetNameArray) To UBound(SheetNameArray)
On Error Resume Next
Set newsht = ThisWorkbook.Sheets(CStr(SheetNameArray(x)))
If Err <> 0 Then
Worksheets.Add
ActiveSheet.Name = CStr(SheetNameArray(x))
Err.Clear
End If
On Error GoTo 0
rng.AutoFilter Field:=26, Criteria1:=SheetNameArray(x)
Set Rng3 = Intersect(rng, .Cells.SpecialCells(xlCellTypeVisible))
Rng3.Copy Workbooks(1).Sheets(CStr(SheetNameArray(x))).Range("A1")
rng.AutoFilter
Next x
End With
Range("A1").Select
Application.Calculation = CalcSetting
Sheets(Array("MACROS", "Flat File")).Select
Sheets("Flat File").Activate
Sheets(Array("MACROS", "Flat File", "DisReport", "DisInput")).Move Before:=Sheets(1)
Sheets("MACROS").Select
End Sub
I have this code below which splits out a file based on distributor (column Z) onto new sheets and names the files based on what is in column Z. However, I came across one that has a "/" in it, which cannot be in the sheet name and causes an error. Was wondering if there is a way to add code to replace the slash (or any special character, if possible) with a space.
Also open to ideas to clean this up. :) I've kind of pieced it together from other codes I've found/asked for help with so it's kind of a mess. I'm not a VBA expert by any means.
Sub aSplitByDistributor()
Workbooks(1).Activate
Dim lastCol As Integer, LastRow As Long, x As Long
Dim rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim SheetNameArray, fn As WorksheetFunction
Dim CalcSetting As Integer
Dim newsht As Worksheet
Set fn = Application.WorksheetFunction
ActiveWorkbook.Worksheets("Flat File").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Flat File").Sort.SortFields.Add Key:=Range( _
"AR:AR"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Flat File").Sort
.SetRange Range("A:AT")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Application
CalcSetting = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With Sheets("Flat File")
Set rng = .UsedRange
Set Rng1 = Intersect(rng, .Range("Z:Z"))
lastCol = rng.Column + rng.Columns.Count - 1
.Range("Z:Z").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, lastCol + 2), Unique:=True
Set Rng2 = Intersect(.Columns(lastCol + 2).CurrentRegion, _
.Rows("2:" & Rows.Count))
ReDim SheetNameArray(1 To Rng2.Cells.Count)
SheetNameArray = fn.Transpose(Rng2)
.Columns(lastCol + 2).Clear
For x = LBound(SheetNameArray) To UBound(SheetNameArray)
On Error Resume Next
Set newsht = ThisWorkbook.Sheets(CStr(SheetNameArray(x)))
If Err <> 0 Then
Worksheets.Add
ActiveSheet.Name = CStr(SheetNameArray(x))
Err.Clear
End If
On Error GoTo 0
rng.AutoFilter Field:=26, Criteria1:=SheetNameArray(x)
Set Rng3 = Intersect(rng, .Cells.SpecialCells(xlCellTypeVisible))
Rng3.Copy Workbooks(1).Sheets(CStr(SheetNameArray(x))).Range("A1")
rng.AutoFilter
Next x
End With
Range("A1").Select
Application.Calculation = CalcSetting
Sheets(Array("MACROS", "Flat File")).Select
Sheets("Flat File").Activate
Sheets(Array("MACROS", "Flat File", "DisReport", "DisInput")).Move Before:=Sheets(1)
Sheets("MACROS").Select
End Sub