如何使用 Excel VBA 循环 link 文本框内容到特定 excel sheet

Question

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

 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

@维克多首先，我要感谢你的贡献，它确实帮助我改进了我的代码。这是我改进后的代码。我还有一点仍然困扰着我，那就是算法对除第一张以外的所有床单都适用。我还是不明白为什么。

私人订阅 CommandButton1_Click() 来电显示呼叫我的子通话清晰来电显示结束子

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

如何使用 Excel VBA 循环 link 文本框内容到特定 excel sheet

How to make a loop to link a textbox content to a specific excel sheet with Excel VBA

excel

vba

textbox

loops

userform