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

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" wrote in message
...

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