从用户窗体复制粘贴

Question

我已经制作了一个用户表单。它包含大约 19 个组合框。组合框有 2 个选项 YES 和 NO。然后在每个组合框前面出现一个文本框，在其中键入 cmets。我想要的是，如果用户从组合框中选择否，我想将该组合框的 cmets 从用户窗体复制粘贴到另一个 Excel 表上。现在我正在复制粘贴所有 cmets。所以我也想添加这个功能。下面是我目前正在使用的代码。任何人都可以帮助我升级此代码，以添加上述功能。

Private Sub ()
Dim ws As Worksheet
Set ws = Worksheets("PQCILDMS")

Dim newRow2 As Long

newRow2 = Application.WorksheetFunction.CountA(ws.Range("A:A")) + 1

ws.Cells(newRow2, 1).Value = cmbDMS.Value

Dim newRow3 As Long


newRow3 = Application.WorksheetFunction.CountA(ws.Range("A:A")) + 1

ws.Cells(newRow3, 1).Value = cmbYesNo.Value

Dim newRow4 As Long

newRow4 = Application.WorksheetFunction.CountA(ws.Range("A:A")) + 1

ws.Cells(newRow4, 1).Value = Me.txtComments.Value

ws.Cells(newRow4, 1).Columns.AutoFit


End Sub

Answer 1

我想从用户窗体中复制粘贴该组合框的 cmets

我想你的意思是复制 TextBox cmets？

处理此问题的最佳方法是将您的组合框命名为ComboBox1, ComboBox2..ComboBox19。同样，对于 TextBoxes，将它们命名为 TextBox1, textBox2... TextBox19。确保TextBox1在ComboBox1前面等等。

我们这样做的原因是为了让循环变得更容易。看这个例子

Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long

    '~~> Change this to the relevant sheet
    Set ws = Sheet1

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1

        For i = 1 To 19
            If Me.Controls("ComboBox" & i).Value = "No" Then
                .Cells(lRow, 1).Value = Me.Controls("TextBox" & i).Value
                lRow = lRow + 1
            End If
        Next i
    End With
End Sub

Answer 2

作为适当重命名彼此面对的texboxes和comboboxes（建议的方法）的替代方法，您可以通过检查文本框是否水平轴（例如：它的中间纵坐标在Userfom layout) 穿过组合框

因此您可以将以下代码放入您的 userfom 代码窗格中：

Option Explicit

Dim Cbs As Collection '<--| set this collection as Userform scoped variable
Dim Tbs As Collection '<--| set this collection as Userform scoped variable


Private Sub CommandButton1_Click()
    Dim cb As MSForms.ComboBox, tb As MSForms.TextBox
    Dim el As Variant

    With Worksheets("PQCILDMS") '<--| reference sheet
        For Each el In Cbs '<--|loop through all userform comboboxes
            Set cb = el '<--|set the current combobox control
            If cb.value = "NO" Then '<--|if its value is "NO" ...
                Set tb = GetTbNextToCb(cb, Tbs) '<--|... look for the textbox whose horizontal axis is inbetween the current combobox
                If Not tb Is Nothing Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).value = tb.value '<--|... if found it then write its content in referenced sheet column "A" next available cell
            End If
        Next el
    End With
End Sub


Function GetTbNextToCb(cb As MSForms.ComboBox, Tbs As Collection) As MSForms.TextBox
    Dim tb As MSForms.TextBox
    Dim cbYMin As Long, cbYMax As Long, tbYMin As Long, tbYMax As Long
    Dim el As Variant

    GetYMinMax cb, cbYMin, cbYMax '<--| get minimum and maximum ordinate of passed combobox

    For Each el In Tbs '<--|loop through all userform textboxes
        Set tb = el '<--|set the current textbox control
        If IsAxisInBetween(tb, cbYMin, cbYMax) Then '<--|if current textbox horizontal axis inbetween passed combobox minimum and maximum ordinates...
            Set GetTbNextToCb = tb '...return the found textbox...
            Exit Function '<--|... and exit function (no need to iterate over remaining textboxes)
        End If
    Next el
End Function

Function IsAxisInBetween(ctrl As Control, yMinRef As Long, yMaxRef As Long) As Boolean
    Dim yMin As Long, yMax As Long

    GetYMinMax ctrl, yMin, yMax '<--| get minimum and maximum ordinates of the control in the userform
    IsAxisInBetween = (yMax + yMin) / 2 <= yMaxRef And (yMax + yMin) / 2 >= yMinRef '<--| check if the control orizontal axis is in between the reference ordinates
End Function

Sub GetYMinMax(ctrl As Control, yMin As Long, yMax As Long)
    With ctrl
        yMin = .Top '<--| get the minimum ordinate of the control in the Userform
        yMax = .Top + .Height '<--| get the maximum ordinate of the control in the Userform
    End With
End Sub



'this sub will run at Userfom loading
Private Sub UserForm_Initialize()
    Set Cbs = GetCtrls("ComboBox") '<--| gather all Userform comboboxes in this collection
    Set Tbs = GetCtrls("TextBox") '<--| gather all Userform texboxes in this collection
End Sub

Function GetCtrls(ctrlTypeName As String) As Collection
    Dim coll As New Collection '<--| declare and set a new Collection object
    Dim ctrl As Control

    For Each ctrl In Me.Controls '<--| loop through all Userform controls
        If TypeName(ctrl) = ctrlTypeName Then '<--| if it matches the passed Type name...
            coll.Add ctrl, ctrl.Name '<--| ... then add it to the collection
        End If
    Next ctrl
    Set GetCtrls = coll '<--| return the collection
End Function