rey06
03-14-2016, 11:24 AM
Hi -
I have the below code which splits a large file I receive based on the value in column Z and renames them based on the same. I've recently run into the issue of some of the values being too long to be a sheet name which causes an error. I've seen codes about how to do this and have tried a few, but nothing seems to work. How could I incorporate something which will just take the first 31 characters of column "Z" for the sheet name so I don't error?
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 Sheets("Flat File")
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
End With
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
Rng1.Replace What:="/", Replacement:=" ", LookAt:=xlPart
.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
Cells.EntireColumn.AutoFit
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 the below code which splits a large file I receive based on the value in column Z and renames them based on the same. I've recently run into the issue of some of the values being too long to be a sheet name which causes an error. I've seen codes about how to do this and have tried a few, but nothing seems to work. How could I incorporate something which will just take the first 31 characters of column "Z" for the sheet name so I don't error?
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 Sheets("Flat File")
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
End With
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
Rng1.Replace What:="/", Replacement:=" ", LookAt:=xlPart
.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
Cells.EntireColumn.AutoFit
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