不重複VBA代碼

我有一個VBA代碼，其被連接到一個用戶窗體不重複VBA代碼

的代碼搜索列標題和通過從用戶窗體

我的問題採取的值與這些標題的列填充是：我怎樣才能避免重複的代碼？

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

來源

2017-02-15 tombata

也許這？相應地調整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

來源

2017-02-15 10:35:57 SJR

適合在陣列中提到的控制，並從那裏閱讀它們！ :)我太懶了:) – Vityata

@Vityata - 謝謝，我知道這種感覺！如果控件都是搜索項+'Box'，那麼可以省去第二個數組，但不想假設。 – SJR

嘗試做這樣的事情：

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

來源

2017-02-15 10:29:37 Vityata

這裏是如何做正確，通過重構你的代碼，以便它的可重複使用的容易：

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 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

來源

2017-02-15 10:38:14 R3uK

不重複VBA代碼

回答

相關問題