VBA实现条件选择并复制到表格中光标所在位置

enoughld

表一和表二
1、表一为原始表，表二为条件筛选表
2、当表二中选择下拉框{日期（按月份）}，点击按钮执行，将表1中日期相等的行复制到表二光标所在位置。
如附件（表一），即若选择2月，则将2月对应的项目复制到表二光标所在位置

enoughld

求助各位大侠帮忙

3190496160

Sub test()
ar = Sheet1.[a1].CurrentRegion
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
yf = Sheet2.[g1]
For i = 2 To UBound(ar)
    s = Val(Format(ar(i, 3), "m"))
    If s = yf Then
        n = n + 1
        For j = 1 To UBound(ar, 2)
            br(n, j) = ar(i, j)
        Next j
    End If
Next i
If n = "" Then MsgBox "没有符合条件的数据": Exit Sub
With Sheet2
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(br, 2)) = br
End With
End Sub

3190496160

条件选择复制.rar (18.35 KB, 下载次数: 11)

2020-3-18 08:59 上传

点击文件名下载附件

enoughld

谢谢，3190496160 ，已测试，好用

enoughld

3190496160 发表于 2020-3-18 08:59

老师，您好，能否帮忙实现输入3月项目信息复制后，再输入4月时4月项目信息自动粘贴到3月项目之后

3190496160

enoughld 发表于 2020-3-18 22:03
老师，您好，能否帮忙实现输入3月项目信息复制后，再输入4月时4月项目信息自动粘贴到3月项目之后

Sub test()
ar = Sheet1.[a1].CurrentRegion
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
yf = Sheet2.[g1]
For i = 2 To UBound(ar)
    s = Val(Format(ar(i, 3), "m"))
    If s = yf Then
        n = n + 1
        For j = 1 To UBound(ar, 2)
            br(n, j) = ar(i, j)
        Next j
    End If
Next i
If n = "" Then MsgBox "没有符合条件的数据": Exit Sub
With Sheet2
    r = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    .Cells(r, 1).Resize(n, UBound(br, 2)) = br
End With
End Sub

enoughld

3190496160 发表于 2020-3-18 23:07
Sub test()
ar = Sheet1.[a1].CurrentRegion
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))

谢谢老师，非常好用，感谢！