如何使用 Excel VBA 循环将文本框内容链接到特定的 Excel 工作表

Question

我创建了一个用户表单，用于跟踪仓库中一组产品的消耗情况，其中每个文本框的内容将分配到不同的 Excel 表（保存消耗历史记录） 我想问一下是否可以创建一个循环来将每个文本框的内容分配给特定的工作表，而不是多次重复代码。
我将非常感谢您的帮助 谢谢你

 Private Sub CommandButton1_Click()

Dim consobav, consobls, consochar As Worksheet
Dim addnewbav, addnewbls, addnewchar As Range
Dim nombrebavettes, nombreblouses, qttbavettes, qttblouses As Integer


Set consobav = Sheet1
Set consobls = Sheet2
Set consochar = Sheet3
'introduire le nombre introduit dans la text box dans le sheet excel
If nbrbavette.Value = "" Then
qttbavettes = 0
Else
nombrebavettes = CInt(ThisWorkbook.Sheets("sheet1").Range("H2").Value)
qttbavettes = CInt(nbrbavette.Value)
End If
If nombrebavettes < qttbavettes Then
MsgBox "qtt insuffisante: " & ThisWorkbook.Sheets("sheet1").Range("A1").Value
Else
Set addnewbav = consobav.Range("A65356").End(xlUp).Offset(1, 0)
addnewbav.Offset(0, 0).Value = qttbavettes
addnewbav.Offset(0, 1).Value = Time & " " & Date
addnewbav.Offset(0, 1).NumberFormat = "d/m/yyyy"
End If

If nbrbls.Value = "" Then
qttblouses = 0
Else
nombreblouses = CInt(ThisWorkbook.Sheets("sheet2").Range("H2").Value)
qttblouses = CInt(nbrbls.Value)
End If
If nombreblouses < qttblouses Then

MsgBox "qtt insuffisante : " & ThisWorkbook.Sheets("sheet2").Range("A1").Value
Else
Set addnewbls = consobls.Range("A65356").End(xlUp).Offset(1, 0)
addnewbls.Offset(0, 0).Value = qttblouses
addnewbls.Offset(0, 1).Value = Time & " " & Date
addnewbls.Offset(0, 1).NumberFormat = "d/m/yyyy"
End If


Set addnewchar = consochar.Range("A65356").End(xlUp).Offset(1, 0)
addnewchar.Offset(0, 0).Value = TextBox1.Value
addnewchar.Offset(0, 1).Value = Time & " " & Date
addnewchar.Offset(0, 1).NumberFormat = "d/m/yyyy"

Call display
Call Somme_consommation_globale
Call seuil_commande
Call display
Call resetform
Call saving_PDF

End Sub

Answer 1

我认为下一个代码可以解决您的问题。 请让我注意您的声明： Dim consobav, consobls, consochar As Worksheet 显示了一个常见错误： consobav 和 consobls 是类型变体，只有 consochar 是工作表。 正确Dim consobav As Worksheet, consobls As Worksheet, consochar As Worksheet 接下来的两行也是如此。

Option Base 1
Private Sub mySub()
    Dim tbAllBoxes() As Variant
    'Put all you textboxes into an array
    tbAllBoxes = Array(ManyText.Controls("Textbox1"), ManyText.Controls("Textbox2"), ManyText.Controls("Textbox3"), ManyText.Controls("Textbox4"))

    Dim shAllSheets As Variant
    'Put all your worksheets into an array
    shAllSheets = Array(Worksheets("1"), Worksheets("2"), Worksheets("3"), Worksheets("4"))
    Dim i As Long
    'Use the pair of textboxes and worksheets
    For i = 1 To UBound(tbAllBoxes)
        ' Example: write the content of textboxes in the sheets in order Textbox1 to worksheet("1")
        shAllSheets(i).Range("A2") = tbAllBoxes(i).Text
        'do whatever you would like
    Next i
End Sub

Answer 2

@维克托 首先，我要感谢您的贡献，它确实帮助我改进了我的代码。 这是我改进后的代码。 我还有一点仍然困扰我的是，除了第一张之外，该算法对所有表格都非常有效。 我还是不明白为什么。

私有子命令按钮1_Click() 来电显示 打电话给我的Sub 呼叫清除 来电显示 结束子

Private Sub mySub()

    Dim lastrow As Integer
    Dim tbAllBoxes() As Variant

    'Put all you textboxes into an array
    tbAllBoxes = Array(SuiviConso.Controls("Textbox1"), SuiviConso.Controls("Textbox2"), SuiviConso.Controls("Textbox3"), SuiviConso.Controls("Textbox4"), SuiviConso.Controls("Textbox5"), SuiviConso.Controls("Textbox6"), SuiviConso.Controls("Textbox7"), SuiviConso.Controls("Textbox8"))

    Dim tballLabels() As Variant
    tballLabels = Array(SuiviConso.Controls("Label1"), SuiviConso.Controls("Label2"), SuiviConso.Controls("Label3"), SuiviConso.Controls("Label4"), SuiviConso.Controls("Label5"), SuiviConso.Controls("Label6"), SuiviConso.Controls("Label7"), SuiviConso.Controls("Label8"))

    Dim shAllSheets As Variant
    'Put all your worksheets into an array
    shAllSheets = Array(ThisWorkbook.Sheets("sheet1"), ThisWorkbook.Sheets("sheet2"), ThisWorkbook.Sheets("sheet3"), ThisWorkbook.Sheets("sheet4"), ThisWorkbook.Sheets("sheet5"), ThisWorkbook.Sheets("sheet6"), ThisWorkbook.Sheets("sheet7"), ThisWorkbook.Sheets("sheet8"))

    Dim i As Long
    'Use the pair of textboxes and worksheets
    'Définir les noms des colonnes
    For i = 1 To UBound(tballLabels)
        shAllSheets(i).Range("A1") = tballLabels(i).Caption
        shAllSheets(i).Range("B1") = "Date"
        shAllSheets(i).Range("G1") = "Consommation globale"
        shAllSheets(i).Range("H1") = "Stock Actuel"
        shAllSheets(i).Range("G1") = "Consommation globale"
        shAllSheets(i).Range("J1") = "Seuil de commande"
        shAllSheets(i).Range("O1") = "Date de réception"
        shAllSheets(i).Range("P1") = "Quantité reçu"

        Next i

    For i = 1 To UBound(tbAllBoxes)
    If tbAllBoxes(i).Value <> "" Then
        Dim txt, cell As Integer
        Dim addnew As Range
        Set addnew = shAllSheets(i).Range("A65356").End(xlUp).Offset(1, 0)
        txt = CInt(tbAllBoxes(i).Value)
        cell = shAllSheets(i).Range("H2").Value
        If txt > cell Then
        MsgBox "Quantité superieur au stock restant de " & "  " & tballLabels(i).Caption
        Else
        'Capturer la valeur introduite par l'utilisateur et les introduire dans le sheet associé
        addnew.Offset(0, 0).Value = tbAllBoxes(i).Value
        addnew.Offset(0, 1).Value = Time & " " & Date
        addnew.Offset(0, 1).NumberFormat = "d/m/yyyy"

        'Vérifier que la quantité introduite est inferieur au stock disponible
        Dim lastrow2 As Integer
        lastrow2 = shAllSheets(i).Range("A" & Rows.Count).End(xlUp).Row
        shAllSheets(i).Range("H2").Value = shAllSheets(i).Range("H2").Value - shAllSheets(i).Range("A" & lastrow2).Value
        End If
    End If
    Next i

    For i = 1 To UBound(tbAllBoxes)

    lastrow = shAllSheets(i).Range("A" & Rows.Count).End(xlUp).Row
    shAllSheets(i).Range("G2") = WorksheetFunction.Sum(shAllSheets(i).Range("A2 : A" & lastrow))
        If shAllSheets(i).Range("G2").Value >= shAllSheets(i).Range("J2") Then
    tballLabels(i).BackColor = RGB(255, 0, 0) 'red
    'rouge ===seuil de commande attient
    Call send_gmail
    Else
    tballLabels(i).BackColor = RGB(0, 255, 0) 'green
    'vert===== produit disponible en quantité suffisante
    End If
    Next i

End Sub

Sub clear() 'effacer les valeurs notés par l'utilisateur aprés la fin de l'opération
Dim i As Integer
Dim tbAllBoxes() As Variant

    'Put all you textboxes into an array
    tbAllBoxes = Array(SuiviConso.Controls("Textbox1"), SuiviConso.Controls("Textbox2"), SuiviConso.Controls("Textbox3"), SuiviConso.Controls("Textbox4"), SuiviConso.Controls("Textbox5"), SuiviConso.Controls("Textbox6"), SuiviConso.Controls("Textbox7"), SuiviConso.Controls("Textbox8"))

    For i = 1 To UBound(tbAllBoxes)
    tbAllBoxes(i).Value = ""
    Next i
End Sub