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

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

一旦程序find满足条件的行（行中存在所有来自文本框的数字），它应该将该行复制到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

四列filter将一次收集所有四列匹配。 过滤结果的副本将仅复制可见行。

 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中的保留字。 我已经重新命名了这些，因为使用与保留字相同的名称声明variables绝不是一个好主意。