[已解决]求教：用VBA进行多条件复制

c888 · 发表于 2011-11-2 13:01

附件中条件已述，谢谢大家。

Book1.rar (4.37 KB, 下载次数: 20)

fjmxwrs · 发表于 2011-11-2 13:38

回复 c888 的帖子

启用宏，点按钮即可
现在上传不了附件，代码如下

Sub TQsj()
Dim arr, arr1(), str_Xm$, str_Lx$, log_Z&, x&, i&, y&, iRow&
With Sheets("2")
arr = .UsedRange
End With
With Sheets("1")
str_Xm = .Range("K6")
str_Lx = .Range("N6")
log_Z = .Range("P6")
For x = 1 To UBound(arr)
If arr(x, 1) = str_Xm And arr(x, 2) = str_Lx And arr(x, 3) = log_Z Then
i = i + 1
ReDim Preserve arr1(1 To 14, 1 To i)
For y = 1 To 14
arr1(y, i) = arr(x, y)
Next y
End If
Next x
iRow = .Range("D65536").End(xlUp).Row
If iRow > 9 Then
.Range("D10:Q" & iRow).ClearContents
.Range("D10:Q" & iRow).Borders.LineStyle = 0
End If
If i = 0 Then MsgBox "没有数据": Exit Sub
.Range("D10").Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
.Range("D10").Resize(UBound(arr1, 2), UBound(arr1)).Borders.LineStyle = 1
MsgBox "提取完毕，共" & i & "人"
End With
End Sub

复制代码

zjdh · 发表于 2011-11-2 13:50

筛选2.rar (10.22 KB, 下载次数: 85)

		自动登录	找回密码
密码			注册