I would really appreciate someone taking a look at this code. I wrote it to go through a bill of materials and match a regular expression pattern to identify certain items and generate a cut list. I'm not really getting any compile errors, but it's also not doing anything at all when it's run. This code is all placed within a module:
Option Explicit
Dim Pattern(1 To 12) As String 'Array of patterns
Dim CellRead As Range
Dim CellWrite As Range
Dim RowCntRead As Integer
Dim RowCntWrite As Integer
Dim ColCntRead As Integer
Dim ColCntWrite As Integer
Sub InitializeArray()
Pattern(1) = "-*"
Pattern(2) = "TS\d*|HSS\d*"
Pattern(3) = "L\d*"
Pattern(4) = "C\d*"
Pattern(5) = "MC\d*"
Pattern(6) = "W\d*"
Pattern(7) = "\d+W\d|GRATE|GRATING"
Pattern(8) = "D\d*"
Pattern(9) = "CF\d*"
Pattern(10) = "FB\d*"
Pattern(11) = "EXP\d*"
End Sub
Function IndexNumber(ByVal InputString As String)
Dim i As Integer 'Pattern index
For i = 1 To UBound(Pattern)
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = Pattern(i)
If .Test(InputString) Then
IndexNumber = i
Exit Function
End If
End With
Next i
IndexNumber = 0
End Function
Function SplitString(ByRef InputString As String, ByVal i As Integer, ByVal Element As Integer)
Dim SplitArray() As String 'Array of substrings
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = Pattern(i)
If .Test(InputString) Then
InputString = .Replace(InputString, "|")
SplitArray = Split(InputString, "|")
SplitString = SplitArray(Element)
Exit Function
End If
End With
SplitString = "--"
End Function
Private Sub NextCellWrite()
ColCntWrite = ColCntWrite + 1
Set CellWrite = Sheets("CUT LIST").Cells(RowCntWrite, ColCntWrite)
End Sub
Sub SetCellRead()
Set CellRead = Sheets("BOM").Cells(RowCntRead, ColCntRead)
End Sub
Sub SetCellWrite()
Set CellWrite = Sheets("CUT LIST").Cells(RowCntWrite, ColCntWrite)
End Sub
Private Sub PopulateCutList_Click()
InitializeArray
Dim PatternNo As Integer 'Pattern identification number
Dim i As Integer 'Pattern parse count
Dim CellReadTimeout As Integer
Dim DetailNo As Variant
Dim MaterialType As String
Dim MaterialSpec As String
Dim JobQty As Integer
Dim CutLength As String
Dim CutCode As String
' ***Initialize***
RowCntRead = 2
RowCntWrite = 4
ColCntRead = 3
ColCntWrite = 1
CellReadTimeout = 0
Set CellRead = Sheets("BOM").Cells(RowCntRead, ColCntRead)
Set CellWrite = Sheets("CUT LIST").Cells(RowCntWrite, ColCntWrite)
'------------------------------------------------------------------
For i = 2 To UBound(Pattern)
Do While CellReadTimeout < 5
PatternNo = IndexNumber(CellRead.Value)
If CellRead.Value <> "" Then
If PatternNo = i Then
Select Case PatternNo
Case 2
MaterialType = "TUBE STEEL (TS)"
Case 3
MaterialType = "ANGLE (L)"
Case 4
MaterialType = "C-CHANNEL (C)"
Case 5
MaterialType = "MC CHANNEL (MC)"
Case 6
MaterialType = "WIDE FLANGE BEAM (W)"
Case 7
MaterialType = "STEEL BAR GRATING, WELDED"
Case 8
MaterialType = "ROUND TUBE"
Case 9
MaterialType = "ROUND BAR"
Case 10
MaterialType = "FLAT BAR"
Case 11
MaterialType = "EXPANDED METAL"
End Select
ColCntRead = 4
SetCellRead
DetailNo = Trim(SplitString(CellRead.Value, 4, 0))
CutCode = Trim(SplitString(CellRead.Value, 4, 1))
ColCntRead = 6
SetCellRead
JobQty = CellRead.Value
ColCntRead = 8
SetCellRead
CutLength = CellRead.Value
ColCntRead = 3
SetCellRead
MaterialSpec = CellRead.Value
CellWrite.Value = DetailNo
NextCellWrite
CellWrite.Value = MaterialType
NextCellWrite
CellWrite.Value = MaterialSpec
NextCellWrite
CellWrite.Value = JobQty
NextCellWrite
CellWrite.Value = CutLength
NextCellWrite
CellWrite.Value = CutCode
RowCntWrite = RowCntWrite + 1
ColCntWrite = 1
CellReadTimeout = 0
End If
RowCntRead = RowCntRead + 1
SetCellRead
Else:
RowCntRead = RowCntRead + 1
SetCellRead
CellReadTimeout = CellReadTimeout + 1
End If
Loop
RowCntRead = 2
SetCellRead
RowCntWrite = RowCntWrite + 2
SetCellWrite
Next i
End Sub
Private Sub ClearBOM_Click()
ThisWorkbook.Worksheets("BOM").Range("A1:J500").ClearContents
End Sub
Private Sub ClearCutList_Click()
ThisWorkbook.Worksheets("CUT LIST").Range("A3:F500").ClearContents
End Sub
Bookmarks