Select Case "Procedure to large" Error

L

Little Penny

A while back. (Thanks to Joel's help) I created a macro that open
files in a specified folder retrieve information from the files and
use a select case statement base on the file name to populate my excel
spreadsheet. It has been working great for some time now but an
increase in the number of files and select case possibilities has
increased to over 450 select case statements and a "Procedure to
large" error.

In many of my statements the only difference is the last charter for
instance. Case "06DD1" Case "06DD2" 3, 4, and 5. Can situation like
this be handle in one statement. This could drastically reduce the
size. If so can the same approach be use if the last character in the
case is a letter. Example: Case "06DFA" Case "06DFB" C, D, E, etc.

I have done a little reading on the procedure to large error and
possible solution.
1. Break out the code in to separate procedures\function. How?
2. Reduce the size of the select case possibilities. How?

What is the best solution to get around this problem?

Sample of my code without all the select case statements.





Sub GetDailyData()
Dim fn As String
Dim ln As String
Dim FirstLine As String
Dim Res As Range
Dim fs, f, fl, fc, s
Dim i As Long
Dim c As Long
Dim LastRow As Long

Dim lx As String




Workbooks.Add
'Sheets.Add
'Cells.Select
'Selection.ClearContents
'Range("A1").Select

Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
Range("A1").Select





Columns("A:A").ColumnWidth = 3

Columns("B:B").ColumnWidth = 11
Columns("C:C").ColumnWidth = 11
Columns("D:D").ColumnWidth = 50
Columns("E:E").ColumnWidth = 10
Columns("F:F").ColumnWidth = 10
Columns("H:H").Select
Selection.NumberFormat = "[$-409]m/d/yy h:mm AM/PM;@"
Columns("H:H").ColumnWidth = 18
Range("A2").Select


Set Res = Range("A1") 'upper left corner of Result range

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("D:\Dfiles\")
Set fc = f.Files

i = 0

With Res

For Each fl In fc

If UCase(Right(fl.Path, 4)) = ".TXT" Then

fn = fl.Path
FirstLine = ""
Open fn For Input As #1
Do While Not EOF(1)

Input #1, ln
If FirstLine = "" Then FirstLine = ln
Loop
Close #1
.Offset(i, 0).Value = "M"
.Offset(i, 1).Value = Left(FirstLine, 8)
.Offset(i, 2).Value = Left(FirstLine, 8)
.Offset(i, 8).NumberFormat = "000000"
'.Offset(i, 11).Value = Mid(FirstLine, 509, 6)
lx = Mid(FirstLine, 509, 6)

'Here I have over 450 Select Case statments

Select Case Left(.Offset(i, 2), 5)

Case "06DD1"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DD2"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DD3"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DD4"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DD5"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DFA"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DFB"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DFC"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DFD"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
..Offset(i, 8).Value = "020808"
Case "06DFE"
..Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx


End Select













.Offset(i, 4).Value = Mid(FirstLine, 9, 6)
.Offset(i, 4).NumberFormat = "0"
.Offset(i, 5).Value = Mid(ln, 9, 6)
.Offset(i, 5).NumberFormat = "0"
.Offset(i, 6).FormulaR1C1 = "=RC[-1]-RC[-2]+1"
.Offset(i, 6).NumberFormat = "0"
.Offset(i, 7).Value = fl.DateLastModified


i = i + 1
End If
Next fl
.Offset(0, 8).EntireColumn.AutoFit
End With



Range("G1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False


With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


.Range("E1:F" & LastRow).Value = 0
End With

Columns("E:E").ColumnWidth = 3

Columns("F:F").ColumnWidth = 3

Columns("G:G").ColumnWidth = 7

Cells.Select
Selection.Sort Key1:=Range("H1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A1").Select

Application.ScreenUpdating = False
LastRow = Range("C65536").End(xlUp).Row

'For c = LastRow To 1 Step -1

'If Cells(c, 4) = "" Then
'Rows(c).EntireRow.Delete
'End If
' Next c
Application.ScreenUpdating = True



Dim aPart As String, ePart As String, shtName As String, FiName As
String

Range("B1").EntireColumn.Cells(Rows.Count, 1).Select
Selection.End(xlUp).Select
aPart = Selection
ePart = Selection.Offset(0, 6)
shtName = aPart & " " & Format(ePart, "m-d-yy h-mmam/pm") & " " &
"Map"
FiName = "Daily Mapping Info " & aPart & " " & Format(ePart,
"m-d-yy h-mmam/pm")
ActiveSheet.Name = shtName

'ActiveWorkbook.SaveAs FileName:=FiName
ActiveWorkbook.SaveAs FileName:="C:\CFiles\" & FiName





Range("A1").Select



End Sub






Thanks

Little Penny
 
R

Rick Rothstein

You can specify the different cases (for which the code to be executed is
the same) as a comma separated list...

Case "06DD1", "06DD2", "06DD3", "06DD4", "06DD5",... etc.
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"

--
Rick (MVP - Excel)


Little Penny said:
A while back. (Thanks to Joel's help) I created a macro that open
files in a specified folder retrieve information from the files and
use a select case statement base on the file name to populate my excel
spreadsheet. It has been working great for some time now but an
increase in the number of files and select case possibilities has
increased to over 450 select case statements and a "Procedure to
large" error.

In many of my statements the only difference is the last charter for
instance. Case "06DD1" Case "06DD2" 3, 4, and 5. Can situation like
this be handle in one statement. This could drastically reduce the
size. If so can the same approach be use if the last character in the
case is a letter. Example: Case "06DFA" Case "06DFB" C, D, E, etc.

I have done a little reading on the procedure to large error and
possible solution.
1. Break out the code in to separate procedures\function. How?
2. Reduce the size of the select case possibilities. How?

What is the best solution to get around this problem?

Sample of my code without all the select case statements.





Sub GetDailyData()
Dim fn As String
Dim ln As String
Dim FirstLine As String
Dim Res As Range
Dim fs, f, fl, fc, s
Dim i As Long
Dim c As Long
Dim LastRow As Long

Dim lx As String




Workbooks.Add
'Sheets.Add
'Cells.Select
'Selection.ClearContents
'Range("A1").Select

Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
Range("A1").Select





Columns("A:A").ColumnWidth = 3

Columns("B:B").ColumnWidth = 11
Columns("C:C").ColumnWidth = 11
Columns("D:D").ColumnWidth = 50
Columns("E:E").ColumnWidth = 10
Columns("F:F").ColumnWidth = 10
Columns("H:H").Select
Selection.NumberFormat = "[$-409]m/d/yy h:mm AM/PM;@"
Columns("H:H").ColumnWidth = 18
Range("A2").Select


Set Res = Range("A1") 'upper left corner of Result range

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("D:\Dfiles\")
Set fc = f.Files

i = 0

With Res

For Each fl In fc

If UCase(Right(fl.Path, 4)) = ".TXT" Then

fn = fl.Path
FirstLine = ""
Open fn For Input As #1
Do While Not EOF(1)

Input #1, ln
If FirstLine = "" Then FirstLine = ln
Loop
Close #1
.Offset(i, 0).Value = "M"
.Offset(i, 1).Value = Left(FirstLine, 8)
.Offset(i, 2).Value = Left(FirstLine, 8)
.Offset(i, 8).NumberFormat = "000000"
'.Offset(i, 11).Value = Mid(FirstLine, 509, 6)
lx = Mid(FirstLine, 509, 6)

'Here I have over 450 Select Case statments

Select Case Left(.Offset(i, 2), 5)

Case "06DD1"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DD2"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DD3"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DD4"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DD5"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DFA"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DFB"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DFC"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DFD"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx
.Offset(i, 8).Value = "020808"
Case "06DFE"
.Offset(i, 3).Value = "STORE 21 DOMESTIC " & "LX# " & lx


End Select













.Offset(i, 4).Value = Mid(FirstLine, 9, 6)
.Offset(i, 4).NumberFormat = "0"
.Offset(i, 5).Value = Mid(ln, 9, 6)
.Offset(i, 5).NumberFormat = "0"
.Offset(i, 6).FormulaR1C1 = "=RC[-1]-RC[-2]+1"
.Offset(i, 6).NumberFormat = "0"
.Offset(i, 7).Value = fl.DateLastModified


i = i + 1
End If
Next fl
.Offset(0, 8).EntireColumn.AutoFit
End With



Range("G1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False


With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


.Range("E1:F" & LastRow).Value = 0
End With

Columns("E:E").ColumnWidth = 3

Columns("F:F").ColumnWidth = 3

Columns("G:G").ColumnWidth = 7

Cells.Select
Selection.Sort Key1:=Range("H1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A1").Select

Application.ScreenUpdating = False
LastRow = Range("C65536").End(xlUp).Row

'For c = LastRow To 1 Step -1

'If Cells(c, 4) = "" Then
'Rows(c).EntireRow.Delete
'End If
' Next c
Application.ScreenUpdating = True



Dim aPart As String, ePart As String, shtName As String, FiName As
String

Range("B1").EntireColumn.Cells(Rows.Count, 1).Select
Selection.End(xlUp).Select
aPart = Selection
ePart = Selection.Offset(0, 6)
shtName = aPart & " " & Format(ePart, "m-d-yy h-mmam/pm") & " " &
"Map"
FiName = "Daily Mapping Info " & aPart & " " & Format(ePart,
"m-d-yy h-mmam/pm")
ActiveSheet.Name = shtName

'ActiveWorkbook.SaveAs FileName:=FiName
ActiveWorkbook.SaveAs FileName:="C:\CFiles\" & FiName





Range("A1").Select



End Sub






Thanks

Little Penny
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Select Case code error 8
Clean this select case code up a bit. 2
Add additional logic to my code 5
Select Case Code does not run... 10
Help merging two VBA codes 2
Copy row info but not in normal column sequence 6
Textbox input goes to 2 sheets in same wbk 0
For, Next, Loop vs. Select / Case Is 6

Top