Question

我有一个VBA代码，它连接到用户表单

代码搜索列标题，并通过获取userform中的值来填充带有这些标题的列

我的问题是：如何避免重复代码？

Dim intBB As Integer
Dim rngBB As Range

intBB = 1

Do While ActiveWorkbook.Worksheets("Sheet1").Cells(1, intBB) <> ""
        If ActiveWorkbook.Worksheets("Sheet1").Cells(1, intBB).Value = "Block" Then
            With ActiveWorkbook.Worksheets("Sheet1")
                Set rngBB = .Range(.Cells(1, intBB), .Cells(1, intBB))

             End With
         Exit Do

        End If
          intBB = intBB + 1
    Loop

ActiveWorkbook.Worksheets("Sheet1").Range(Cells(2, intBB), Cells(LastRow, intBB)).Value = BlockBox.Value

intBB = 1

Do While ActiveWorkbook.Worksheets("Sheet1").Cells(1, intBB) <> ""
        If ActiveWorkbook.Worksheets("Sheet1").Cells(1, intBB).Value = "HPL" Then
            With ActiveWorkbook.Worksheets("Sheet1")
                Set rngBB = .Range(.Cells(1, intBB), .Cells(1, intBB))

             End With
         Exit Do

        End If
          intBB = intBB + 1
    Loop

ActiveWorkbook.Worksheets("Sheet1").Range(Cells(2, intBB), Cells(LastRow, intBB)).Value = HPLBox.Value

Answer 1

也许这个？相应地调整w1和w2。

Sub x()

Dim rngBB As Range
Dim v, w1, w2, i As Long

w1 = Array("Block", "HPL")
w2 = Array("Blockbox", "HPLBox")

For i = LBound(w1) To UBound(w1)
    With ActiveWorkbook.Worksheets("Sheet1")
        v = Application.Match(w1(i), .Rows(1), 0)
        If IsNumeric(v) Then
            Set rngBB = .Cells(1, v)
            .Range(.Cells(2, v), .Cells(LastRow, v)).Value = Me.Controls(w2(i)).Value
        End If
    End With
Next i

End Sub

Answer 2

以下是如何通过重构您的代码来正确完成它，以便它可以轻松重复使用：

Sub test_tombata()
    Dim wSh As Worksheet
    Set wSh = ActiveWorkbook.Sheets("Sheet1")

    Fill_Column_From_Header wSh, "Block", BlockBox.Value
    Fill_Column_From_Header wSh, "HPL", HPLBox.Value
End Sub

使用sub用值填充列：

Sub Fill_Column_From_Header(wS As Worksheet, HeaderName As String, ValueToFill As String)
    Dim LastRow As Double
    With wS
        LastRow = .Cells(.Rows.Count, intBB).End(xlUp).Row
        wSh.Range(Cells(2, intBB), Cells(LastRow, intBB)).Value = ValueToFill
    End With 'wS
End Sub

使用一个函数为您提供标题名称中的列号：

Function Get_Column_From_Header(wS As Worksheet, HeaderName As String) As Integer
    Dim intBB As Integer
    intBB = 1
    Get_Column_From_Header = 0
    With wS
        Do While .Cells(1, intBB) <> ""
            If .Cells(1, intBB).Value <> HeaderName Then
            Else
                Get_Column_From_Header = intBB
                Exit Function
            End If
            intBB = intBB + 1
        Loop
    End With 'wS
End Function

我只想补充说，如果此代码在常规模块中，则必须使用：
USERFORMNAME.BlockBox.Value而非BlockBox.Value

Answer 3

尝试做这样的事情：

dim wks     as worksheet

set wks = ActiveWorkbook.Worksheets("Sheet1")
With wks

    call LoopMe("Block", wks)
    .Range(Cells(2, intBB), Cells(LastRow, intBB)).Value = BlockBox.Value

    call LoopMe("HPL", wks)
    .Range(Cells(2, intBB), Cells(LastRow, intBB)).Value = HPLBox.Value

End with 



Public Sub LoopMe(strString as string, wks as worksheet)

    dim intBB as long : intBB = 1

    with wks
        Do While .Cells(1, intBB) <> ""
        If .Cells(1, intBB).Value = "Block" Then
            Set rngBB = .Range(.Cells(1, intBB), .Cells(1, intBB))
             Exit Do
        End If
          intBB = intBB + 1
        Loop
    end with

End Sub

不重复VBA代码

3 个答案: