VBA - conditional error with code involving LBound(SheetNameArray) To UBound(SheetNam

[rey06]

Hi-

I have a series of macros that I used for one of my tasks. I'm having issues with the below but only in certain situations. This part of my macro breaks apart a large file based on what is in column Z, but if there is only one item in column Z, I get a mismatch error and the line "For x = LBound(SheetNameArray) To UBound(SheetNameArray)" is highlighted. I could just do the part of the macro for those and give them their own tab to begin with, but when I have several to do or if someone else would ever have to fill in, I'd like some consistency. I did test it just now to confirm that the code DOES work on those files that have more than one different string in column Z but DOES NOT work if it's all the same.

And ideas? The issue I'm having as stated above is between the "***" below.


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(Left(SheetNameArray(x), 31))
If Err <> 0 Then
Worksheets.Add
ActiveSheet.Name = Left(SheetNameArray(x), 31)
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(Left(SheetNameArray(x), 31)).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

[SamT]

Set Rng2 = Cells(2, lastCol + 2)
Set Rng2 = Range(Rng2, Cells(Rows.Count, Rng2.Column).End(xlUp))

If Rng2.Count = 1 Then
MakeSheet Rng2
Else
ReDim SheetNameArray(1 To Rng2.Cells.Count)
SheetNameArray = fn.Transpose(Rng2)
Rng2.Clear
For x = LBound(SheetNameArray) To UBound(SheetNameArray)***
MakeSheet SheetNameArray(x)
Next
End If
End Sub


Private Sub MakeSheet(ShtName As String)
Dim newsht as Worksheet
On Error GoTo SubEnd
Set newsht = ThisWorkbook.Sheets(Left(ShtName, 31))

Worksheets.Add
ActiveSheet.Name = Left(shtName, 31)

SubEnd:
End Sub

[rey06]

Hi Sam, thanks for the response.

Do I just replace the top box with the bottom?

[SamT]

No. Those were just to give you a different idea about how to rewrite your code. You still need to move the Rng3.Copy section to it's own Sub and call it every time Rng2 is accessed.


Sub CopyData(NewSht As WorkSheet)
With ThisWorkbook.UsedRange
.AutoFilter Field:=26, Criteria1:=SheetNameArray(x)
.Cells.SpecialCells(xlCellTypeVisible).Copy NewSht.Range("A1")
.AutoFilter
.Cells.EntireColumn.AutoFit
End With
End Sub

I think that if you figure out what my code does, you can integrate it into your code. Anyway. The boss is here, Gotta run. HTH you.

[rey06]

Sorry for not getting to this sooner. Busy week last week. I'm trying out the first code you suggested, and I'm getting stuck on the MakeSheet line. (Compile error: Sub or Function not defined).

[SamT]

The Running sub can't find MakeSheet. Are they in the same module? If not MakeSheet must be Public

[rey06]

Yeah, it's all in the same module. I think I just might make a note that if there is only one distributor to place it on it's own tab. I have this whole thing set up with 6 different buttons and one master that calls them all. Might be easier just to not try to incorporate this into my existing code.

[SamT]

6 different buttons and one master that calls them all.I don't understand what that means.

[rey06]

6 different buttons and one master that calls them all.I don't understand what that means.

Long story short, I just kept adding to what I wanted to be done with this file I get. It started out that I just wanted a quicker way to break my file apart by distributor, but then I realized I could do a whole lot more. Instead of having one large code to do everything, I just kept writing new codes. Each of these codes does it's own part and I have a button for each one to make it as easy as possible for someone else to jump into. Made it easier to debug along the way! If I want to just run them all, I made another button that just runs all three codes in order. I probably way over complicated it, but I literally just started using VBA within the last 2 months :) I just don't know if it's worth going through the hassle for something that doesn't happen all that often. But I appreciate the suggestions! I just can't seem to make anything work.