EXCEL 行遍历，备用

要对一张表格进行行遍历，再做一些处理。

处理有多种，如果分开写，每一个处理中，都有行遍历的代码，因此将行遍历的代码提出来，作成一个类，各处理只要处理 RowProcess(ByVal rowIndex As Long) 的事件就可以了。

RowLoop classmodule:

Option Explicit

Private inner_sheet As Worksheet
Private cells As Range
Private inner_indexFrom, inner_indexTo, currentIndex As Long
Private inner_txtIndexFrom, inner_txtIndexTo As MSForms.textbox
Private inner_keyColumnChar As String
Private inner_blankRowCount As Integer

Private inner_progressBar As MSComctlLib.progressBar
Private inner_progressLabel As MSForms.Label

Public Event RowProcess(ByVal rowIndex As Long)
Public Event updateProgress(ByVal percent As Integer)
Public Event Complete(ByRef handled As Boolean)


Public Property Set sheet(ByRef value As Worksheet)
    Set inner_sheet = value
End Property

Public Property Let indexFrom(ByVal value As Long)
    inner_indexFrom = value
End Property

Public Property Get indexForm() As Long
    indexForm = inner_indexFrom
End Property

Public Property Let indexTo(ByVal value As Long)
    inner_indexTo = value
End Property

Public Property Get indexTo() As Long
    indexTo = inner_indexTo
End Property

Public Property Set txtIndexFrom(ByRef value As MSForms.textbox)
    Set inner_txtIndexFrom = value
End Property

Public Property Set txtIndexTo(ByRef value As MSForms.textbox)
    Set inner_txtIndexTo = value
End Property

Public Property Let keyColumnChar(ByVal value As String)
    inner_keyColumnChar = value
End Property

Public Property Let blankRowCount(ByVal value As Integer)
    inner_blankRowCount = value
End Property

Public Property Set progressBar(ByRef value As progressBar)
    Set inner_progressBar = value
End Property

Public Property Set progressLabel(ByRef value As MSForms.Label)
    Set inner_progressLabel = value
End Property

Private Sub Class_Initialize()
    Set inner_sheet = Nothing
    Set inner_txtIndexFrom = Nothing
    Set inner_txtIndexTo = Nothing
    inner_keyColumnChar = ""
    inner_blankRowCount = 3
    Set inner_progressBar = Nothing
    Set inner_progressLabel = Nothing
End Sub

Private Sub setProgressStatus()
    Dim percent As Integer
    If currentIndex = inner_indexTo Then
        percent = 100
    Else
        percent = CInt(currentIndex * 100 / (inner_indexTo - inner_indexFrom))
        If percent > 100 Then percent = 100
    End If
    RaiseEvent updateProgress(percent)
End Sub

Public Sub doLoop()
    If inner_sheet Is Nothing Then
        Set cells = ActiveSheet.cells
    Else
        Set cells = inner_sheet.cells
    End If
    
    If Not inner_txtIndexFrom Is Nothing Then
        If isEmpty(inner_txtIndexFrom, "Start Row Index") Then
            Exit Sub
        Else
            inner_indexFrom = CLng(inner_txtIndexFrom.Text)
        End If
    End If
    
    If Not inner_txtIndexTo Is Nothing Then
        If isEmpty(inner_txtIndexTo, "End Row Index") Then
            Exit Sub
        Else
            inner_indexTo = CLng(inner_txtIndexTo.Text)
        End If
    End If

    If inner_indexFrom < 1 Or inner_indexTo <= inner_indexFrom Then
        MsgBox "start row index must greater than 0 and end row index must greater than start row index."
        Exit Sub
    End If

    Dim i, blankCount As Long
    Dim isHandled As Boolean
    isHandled = False
    blankCount = 0
    For i = inner_indexFrom To inner_indexTo
        currentIndex = i
        If getKeyCell().value <> "" Then
            blankCount = 0
            RaiseEvent RowProcess(currentIndex)
        Else
            getKeyCell().Interior.Color = vbYellow
            blankCount = blankCount + 1
            If blankCount = inner_blankRowCount Then
                MsgBox "find " & inner_blankRowCount & " blank rows, process stop!"
                RaiseEvent Complete(isHandled)
                Exit Sub
            End If
        End If
        setProgressStatus
    Next i

    RaiseEvent Complete(isHandled)
    If Not isHandled Then
        MsgBox "Process is complete."
    End If
End Sub

Public Function isEmpty(ByVal txt As MSForms.textbox, ByVal itemName As String) As Boolean
    If txt.value = "" Then
        MsgBox "Please input " & itemName & "."
        txt.SetFocus
        isEmpty = True
    Else
        isEmpty = False
    End If
End Function

Public Function getKeyCell(Optional ByVal rowIndex As Long = 0) As Range
    If rowIndex = 0 Then rowIndex = currentIndex
    Set getKeyCell = cells.Range(inner_keyColumnChar & rowIndex)
End Function

Public Function getCell(ByVal columnChar As String) As Range
    Set getCell = cells.Range(columnChar & currentIndex)
End Function

Public Sub setCellText(ByVal columnChar As String, ByVal value As String)
    cells.Range(columnChar & currentIndex).value = value
End Sub

Form Code:

Option Explicit
Dim WithEvents rl As RowLoop
Dim which As Integer
Dim sqlResult As String

Private Sub cmdRun1_Click()
    Set rl = New RowLoop
    which = 1
    
    If rl.isEmpty(txtColumnChar, "Column Char") Then Exit Sub
    rl.keyColumnChar = txtColumnChar.value
    Set rl.txtIndexFrom = txtFrom1
    Set rl.txtIndexTo = txtTo1
    rsInitialize rl
    Set rl = Nothing
End Sub

Private Sub cmdRun2_Click()
    Set rl = New RowLoop
    which = 2
    
    If rl.isEmpty(txtBarCodeColumnChar, "BarCode Column Char") Then Exit Sub
    rl.keyColumnChar = txtBarCodeColumnChar.value
    Set rl.txtIndexFrom = txtFrom2
    Set rl.txtIndexTo = txtTo2
    aiInitialize rl, txtAreaColumnChar.value, txtCategoryFrom.value
    Set rl = Nothing
End Sub

Private Sub cmdRun3_Click()
    Set rl = New RowLoop
    which = 3
    
    Set rl.txtIndexFrom = txtFrom3
    Set rl.txtIndexTo = txtTo3
    
    Dim ctrls As JF_Controls
    Set ctrls.txtShotName = txtShotName
    Set ctrls.txtStander = txtStander
    Set ctrls.txtModule = txtModule
    Set ctrls.txtFullName = txtFullName
    
    jfInitialize rl, ctrls
    Set rl = Nothing
End Sub

Private Sub cmdRun4_Click()
    Dim options As sqlOutputOptions
    options.checkNewCode = chkNewCode.value
    options.checkEntryCode = chkEntryCode.value
    options.checkFullName = chkFullName.value
    options.checkUnit = chkUnit.value
    options.checkSimpleName = chkSimpleName.value
    options.checkStander = chkStander.value
    options.checkModule = chkModule.value
    options.checkArea = chkArea.value
    options.checkPrices = chkPrices.value
    
    Dim ctrls As sqlFormControls
    Set ctrls.txtCode = txtCode
    Set ctrls.txtColumnList = txtCols
    Set ctrls.txtFrom = txtFrom4
    Set ctrls.txtTo = txtTo4
    Set ctrls.txtResult = txtResult
    
    Set rl = New RowLoop
    which = 4
    'Set rl.progressBar = pbar4
    'Set rl.progressLabel = plbl4
    sqlInitialize options, ctrls, rl
    Set rl = Nothing
End Sub

Private Sub cmdSetAppearance_Click()
    setAppearance
End Sub

Private Sub cmdCopy_Click()
    If txtResult.value = "" Then Exit Sub
    copy2clipborder txtResult.value
End Sub

Private Sub rl_Complete(handled As Boolean)
    Select Case which
        Case 4: doSQLDone
    End Select
End Sub

Private Sub rl_RowProcess(ByVal rowIndex As Long)
    Select Case which
        Case 1: doSeek rowIndex
        Case 2: doAIMake rowIndex
        Case 3: doJoin
        Case 4: doGetSQL rowIndex
    End Select
End Sub

Private Sub rl_updateProgress(ByVal percent As Integer)
    Select Case which
        Case 1:
            pbar1.value = percent
            plbl1.Caption = percent & "%"
        Case 2:
            pBar2.value = percent
            plbl2.Caption = percent & "%"
        Case 3:
            pbar3.value = percent
            plbl3.Caption = percent & "%"
        Case 4:
            pbar4.value = percent
            plbl4.Caption = percent & "%"
    End Select
End Sub

mdlMain:

Option Explicit


Sub showToolForm()
    frmProductTool.Show
End Sub

Function padleft(value, length)
    Dim i As Integer
    If Len(value) < length Then
      For i = 1 To length - Len(value)
        value = ":" & value
      Next i
    End If
    
    padleft = value
End Function

Sub copy2clipborder(ByVal strng As String)
    Dim MyData As DataObject
    
    Set MyData = New DataObject
    MyData.Clear
    MyData.SetText strng
    MyData.PutInClipboard
End Sub

mdlAreaIndex:

Option Explicit


Private inner_rl As RowLoop
Private inner_areaIndexColumn As String

Private typeIndex1, typeIndex2, itemIndex As Integer
Private lastTypeStr1, lastTypeStr2 As String


Sub aiInitialize(ByVal rl As RowLoop, ByVal areaIndexColumn As String, ByVal categoryIndexFrom As Integer)
    Set inner_rl = rl
    inner_areaIndexColumn = areaIndexColumn
    
    typeIndex1 = categoryIndexFrom - 1
    typeIndex2 = 0
    itemIndex = 0
    lastTypeStr1 = ""
    lastTypeStr2 = ""
        
    rl.doLoop
End Sub

Sub doAIMake(ByVal currentIndex As Long)
    If lastTypeStr1 <> Left(inner_rl.getKeyCell().Text, 1) Then
      typeIndex1 = typeIndex1 + 1
      typeIndex2 = 1
      itemIndex = 1
      
      lastTypeStr1 = Left(inner_rl.getKeyCell().Text, 1)
      lastTypeStr2 = Mid(inner_rl.getKeyCell().Text, 2, 1)
      
    ElseIf lastTypeStr2 <> Mid(inner_rl.getKeyCell().Text, 2, 1) Then
      typeIndex2 = typeIndex2 + 1
      itemIndex = 1
      
      lastTypeStr2 = Mid(inner_rl.getKeyCell().Text, 2, 1)
    Else
      itemIndex = itemIndex + 1
    End If
    
    Dim result As String
    result = "'" & padleft(CStr(typeIndex1), 3) & padleft(CStr(typeIndex2), 3) & padleft(CStr(itemIndex), 3)
    inner_rl.setCellText inner_areaIndexColumn, result
End Sub

mdlGetSql:

Option Explicit

Type sqlOutputOptions
    checkNewCode As Boolean
    checkEntryCode As Boolean
    checkFullName As Boolean
    checkUnit As Boolean
    checkSimpleName As Boolean
    checkStander As Boolean
    checkModule As Boolean
    checkArea As Boolean
    checkPrices As Boolean
End Type

Type sqlFormControls
    txtCode As MSForms.textbox
    txtColumnList As MSForms.textbox
    txtFrom As MSForms.textbox
    txtTo As MSForms.textbox
    txtResult As MSForms.textbox
End Type

Type sqlColumnChar
    code As String
    newCode As String
    entryCode As String
    fullName As String
    unit As String
    simpleName As String
    stander As String
    module As String
    area As String
    prices As String
End Type

Dim result As String
Dim columnChar As sqlColumnChar
Dim inner_rl As RowLoop
Dim inner_options As sqlOutputOptions
Dim inner_controls As sqlFormControls

Public Sub sqlInitialize(ByRef options As sqlOutputOptions, ByRef controls As sqlFormControls, ByVal rl As RowLoop)
    If rl.isEmpty(controls.txtCode, "code column char") Then Exit Sub
    If rl.isEmpty(controls.txtColumnList, "column char list") Then Exit Sub
    
    Dim columnList As String
    columnList = controls.txtColumnList.value
    If Len(columnList) <> 9 Then
        MsgBox "column char list must be a 9 length chaters"
        controls.txtColumnList.SetFocus
        Exit Sub
    End If
    
    columnChar.code = controls.txtCode.value
    columnChar.newCode = Left(columnList, 1)
    columnChar.entryCode = Mid(columnList, 2, 1)
    columnChar.fullName = Mid(columnList, 3, 1)
    columnChar.unit = Mid(columnList, 4, 1)
    columnChar.simpleName = Mid(columnList, 5, 1)
    columnChar.stander = Mid(columnList, 6, 1)
    columnChar.module = Mid(columnList, 7, 1)
    columnChar.area = Mid(columnList, 8, 1)
    columnChar.prices = Mid(columnList, 9, 1)
    
    rl.keyColumnChar = controls.txtCode.value
    Set rl.txtIndexFrom = controls.txtFrom
    Set rl.txtIndexTo = controls.txtTo
    
    result = ""
    Set inner_rl = rl
    inner_options = options
    inner_controls = controls
    inner_rl.doLoop
End Sub

Public Sub doGetSQL(ByVal currentIndex As Long)
    Dim haveField As Boolean
    haveField = False
    If result <> "" Then result = result & vbCrLf
    result = result & "UPDATE ptype SET "
    result = result & getField(inner_options.checkNewCode, "usercode", columnChar.newCode, haveField)
    result = result & getField(inner_options.checkEntryCode, "entrycode", columnChar.entryCode, haveField)
    result = result & getField(inner_options.checkFullName, "fullname", columnChar.fullName, haveField)
    result = result & getField(inner_options.checkUnit, "unit1", columnChar.unit, haveField)
    result = result & getField(inner_options.checkSimpleName, "name", columnChar.simpleName, haveField)
    result = result & getField(inner_options.checkStander, "standard", columnChar.stander, haveField)
    result = result & getField(inner_options.checkModule, "type", columnChar.module, haveField)
    result = result & getField(inner_options.checkArea, "area", columnChar.area, haveField)
    'result = result & getField(inner_options.checkprices, "usercode", columnChar.newCode)  preprice1
    result = result & " WHERE usercode = '" & inner_rl.getCell(columnChar.code).value & "';"
End Sub

Private Function getField(ByVal flag As Boolean, ByVal fieldName As String, ByVal columnChar As String, ByRef haveField) As String
    If Not flag Then
        getField = ""
        Exit Function
    End If
    
    getField = fieldName & " = '" & inner_rl.getCell(columnChar).value & "'"
    
    If haveField Then
        getField = ", " & getField
    Else
        haveField = True
    End If

End Function

Public Sub doSQLDone()
    inner_controls.txtResult.value = result
End Sub

mdlJoinFullName:

Option Explicit

Type JF_Controls
    txtShotName As MSForms.textbox
    txtStander As MSForms.textbox
    txtModule As MSForms.textbox
    txtFullName As MSForms.textbox
End Type

Private inner_rl As RowLoop
Private controls As JF_Controls


Sub jfInitialize(ByVal rl As RowLoop, ByRef ctrls As JF_Controls)
    controls = ctrls
    
    If rl.isEmpty(ctrls.txtShotName, "Short Name Column Char") Then Exit Sub
    If rl.isEmpty(ctrls.txtStander, "stander Column Char") Then Exit Sub
    If rl.isEmpty(ctrls.txtModule, "Module Column Char") Then Exit Sub
    If rl.isEmpty(ctrls.txtFullName, "FullName Column Char") Then Exit Sub
    
    rl.keyColumnChar = ctrls.txtShotName.value
    Set inner_rl = rl
    rl.doLoop

End Sub

Sub doJoin()
    Dim result As String
    result = inner_rl.getKeyCell().Text
    If inner_rl.getCell(controls.txtModule.value).Text <> "" Then
        result = result & " " & inner_rl.getCell(controls.txtModule.value).Text
        If inner_rl.getCell(controls.txtStander.value).Text <> "" Then
            result = result & "/" & inner_rl.getCell(controls.txtStander.value).Text
        End If
    ElseIf inner_rl.getCell(controls.txtStander.value) <> "" Then
        result = result & " " & inner_rl.getCell(controls.txtStander.value).Text
    End If
    inner_rl.setCellText controls.txtFullName.value, result
End Sub

mdlRepeatSeek:

Option Explicit

Private inner_rl As RowLoop

Sub rsInitialize(ByVal rl As RowLoop)
    Set inner_rl = rl
    rl.doLoop
End Sub

Sub doSeek(ByVal currentIndex As Long)
    Dim i As Long
    For i = currentIndex + 1 To inner_rl.indexTo
        If inner_rl.getKeyCell().Text = inner_rl.getKeyCell(i) Then
            inner_rl.getKeyCell(i).Interior.Color = vbRed
            Exit For
        End If
    Next i
End Sub

mdlSetAppearance:

Sub setAppearance()
    ' delete header
    Rows("1:14").Delete Shift:=xlUp
    
    Columns("F:L").ColumnWidth = 1.5
    Columns("B:B").ColumnWidth = 20
    Columns("D:D").ColumnWidth = 1.5
    Columns("E:E").ColumnWidth = 4
    Columns("M:M").ColumnWidth = 20
    Columns("N:N").ColumnWidth = 24
    Columns("O:O").ColumnWidth = 24
    Columns("P:P").ColumnWidth = 10
    Columns("Q:R").ColumnWidth = 1.5
    
    With Range("B1:E1").Interior
        .ColorIndex = 54
        .Pattern = xlSolid
    End With
    Range("B1:E1").Font.ColorIndex = 2
    
    With Range("M1:P1").Interior
        .ColorIndex = 54
        .Pattern = xlSolid
    End With
    Range("M1:P1").Font.ColorIndex = 2
    
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    'ActiveWindow.SmallScroll Down:=-15
End Sub