Question

我有一张随机数字的Excel表格。在我的用户表单上，我有4个数字文本框。

一旦程序找到符合条件的行（文本框中的所有数字都出现在行中），它应该将该行复制到sheet2。

我不知道该怎么做。

Dim rngFound As Range
Dim strFirst As String
Dim Height As String
Dim Width As String
Dim MountB As String
Dim MountC As String

Height = TextBox1.Value
Width = TextBox2.Value
MountB = TextBox3.Value
MountC = TextBox4.Value

If Trim(TextBox1.Value & vbNullString) = vbNullString Or Trim(TextBox2.Value & vbNullString) = vbNullString Or Trim(TextBox3.Value & vbNullString) = vbNullString _
    Or Trim(TextBox4.Value & vbNullString) = vbNullString Then

MsgBox "Enter the missing value(s)"

Else

Set rngFound = Columns("B").Find(Height, Cells(Rows.Count, "B"), xlValues, xlWhole)


If Not rngFound Is Nothing Then
    strFirst = rngFound.Address
    Do
        If LCase(Cells(rngFound.Row, "C").Text) = LCase(Width) And LCase(Cells(rngFound.Row, "D").Text) = LCase(MountB) And LCase(Cells(rngFound.Row, "E").Text) = LCase(MountC) Then
            'Found a match
           Range(rngFound.Row & Chr(10)).Copy _
           Destination:=Worksheets("data").b

            MsgBox "Found a match at: " & rngFound.Row & Chr(10) & _
                   "BLOCK TYPE: " & Cells(rngFound.Row, "A").Text & Chr(10) & _
                   "BLOCK LENGHT [L] mm: " & Cells(rngFound.Row, "F").Text & Chr(10) & _
                   "SCREW SIZE [Mxl]: " & Cells(rngFound.Row, "G").Text & Chr(10) & _
                   "RAIL WIDTH [Wr] mm: " & Cells(rngFound.Row, "H").Text & Chr(10) & _
                   "COUNTERBORE DIAM [D] mm: " & Cells(rngFound.Row, "I").Text & Chr(10) & _
                   "COUNTERBORE DEPTH [h] mm: " & Cells(rngFound.Row, "J").Text & Chr(10) & _
                   "THRU HOLE DIAM [d] mm: " & Cells(rngFound.Row, "K").Text & Chr(10) & _
                   "RAIL PITCH [P] mm: " & Cells(rngFound.Row, "L").Text & Chr(10) & _
                   "E DIMENSION [E] mm: " & Cells(rngFound.Row, "M").Text & Chr(10) & _
                   "BASIC DYNAMIC LOAD [C] kN: " & Cells(rngFound.Row, "N").Text & Chr(10) & _
                   "BASIC STATIC LOAD [C0] kN: " & Cells(rngFound.Row, "O").Text & Chr(10) & _
                   "STATIC MOMENT [MR] kNm: " & Cells(rngFound.Row, "P").Text & Chr(10) & _
                   "STATIC MOMENT [MP] kNm: " & Cells(rngFound.Row, "Q").Text & Chr(10) & _
                   "STATIC MOMENT [MY] kNm: " & Cells(rngFound.Row, "R").Text


        End If


        Set rngFound = Columns("B").Find(Height, rngFound, xlValues, xlWhole)


    Loop While rngFound.Address <> strFirst

Else
        MsgBox "No CROSS"

End If
End If



 Set rngFound = Nothing



End Sub

Answer 1

四列过滤器将同时收集所有四列匹配。过滤结果的副本仅复制可见行。

Sub match_4_and_copy()
    Dim rngFound As Range
    Dim strFirst As String
    Dim sHeight As String
    Dim sWidth As String
    Dim sMountB As String
    Dim sMountC As String
    Dim rw As Long

    sHeight = TextBox1.Value
    sWidth = TextBox2.Value
    sMountB = TextBox3.Value
    sMountC = TextBox4.Value

    With ActiveSheet   '<-define this worksheet properly!
        If Not CBool(Len(Trim(TextBox1.Value))) Or _
           Not CBool(Len(Trim(TextBox2.Value))) Or _
           Not CBool(Len(Trim(TextBox3.Value))) Or _
           Not CBool(Len(Trim(TextBox4.Value))) Then

            MsgBox "Enter the missing value(s)"

        ElseIf CBool(Application.CountIfs(.Columns("B"), sHeight, _
                                          .Columns("C"), sWidth, _
                                          .Columns("D"), sMountB, _
                                          .Columns("E"), sMountC)) Then
            With .Cells(1, 1).CurrentRegion
                .AutoFilter
                .AutoFilter field:=2, Criteria1:=sHeight
                .AutoFilter field:=3, Criteria1:=sWidth
                .AutoFilter field:=4, Criteria1:=sMountB
                .AutoFilter field:=5, Criteria1:=sMountC
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    .Cells.Copy _
                       Destination:=Worksheets("data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                End With
                .AutoFilter
            End With

            With Worksheets("data")
                For rw = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
                    'put your big mssg box here based on rw
                Next rw
            End With
        Else

            MsgBox "No CROSS"

        End If
    End With
            'MsgBox "Found a match at: " & rngFound.Row & Chr(10) & _
                   "BLOCK TYPE: " & Cells(rngFound.Row, "A").Text & Chr(10) & _
                   "BLOCK LENGHT [L] mm: " & Cells(rngFound.Row, "F").Text & Chr(10) & _
                   "SCREW SIZE [Mxl]: " & Cells(rngFound.Row, "G").Text & Chr(10) & _
                   "RAIL WIDTH [Wr] mm: " & Cells(rngFound.Row, "H").Text & Chr(10) & _
                   "COUNTERBORE DIAM [D] mm: " & Cells(rngFound.Row, "I").Text & Chr(10) & _
                   "COUNTERBORE DEPTH [h] mm: " & Cells(rngFound.Row, "J").Text & Chr(10) & _
                   "THRU HOLE DIAM [d] mm: " & Cells(rngFound.Row, "K").Text & Chr(10) & _
                   "RAIL PITCH [P] mm: " & Cells(rngFound.Row, "L").Text & Chr(10) & _
                   "E DIMENSION [E] mm: " & Cells(rngFound.Row, "M").Text & Chr(10) & _
                   "BASIC DYNAMIC LOAD [C] kN: " & Cells(rngFound.Row, "N").Text & Chr(10) & _
                   "BASIC STATIC LOAD [C0] kN: " & Cells(rngFound.Row, "O").Text & Chr(10) & _
                   "STATIC MOMENT [MR] kNm: " & Cells(rngFound.Row, "P").Text & Chr(10) & _
                   "STATIC MOMENT [MP] kNm: " & Cells(rngFound.Row, "Q").Text & Chr(10) & _
                   "STATIC MOMENT [MY] kNm: " & Cells(rngFound.Row, "R").Text

End Sub

我会留给您正确定义复制和目的地范围。 MsgBox已注释，但您应该能够将其放入我保留空间的For / Next循环中。循环基于 rw 遍历每个复制的行。

请注意，高度和宽度是VBA中的保留字。我已经重命名了这些，因为使用与保留字相同的名称声明变量绝不是一个好主意。

匹配4个单元格并复制一行

1 个答案: