利用VBA宏，对符合条件，对整行有选择的复制到当前表格中

Zhjonhse

请教：
如表SSS中17A所示，除了表头外，符合/等于H列中某数值条件的，对整行有选择的列进行复制或链接到另一表“TTT.政治”表中，其中表头行数和SSS源表中相同。
例如：对“SSS.17A”的H列中的“政治”进行筛选，并复制或链接，则可以在表TTT.政治表中得到相应结果。
要求：
1）        能否在运行宏时，有个可选项就是对源表的选择。同时，也对关键字“政治”进行对话式选择/填入这样增加通用性。
2）        一般在目标表中操作，本例中，就是在“TTT.政治”表中操作。
3）        源表和目标表的表头不变，就是不用管它，但复制或链接时，从第4行开始，不破坏原表头。
4）        复制或链接的数据格式和源表一样。
5）        能否对符合条件的整行中，只复制或链接其中的A—AD列，和BB-BY列。
6）        由于本人还没有入门，由于源表数据量大，不清楚复制还是链接更容易实现，或更速度快些，建议以降低CPU和内存耗用为目的，原来我用数组公式做的运转速度太慢了。如果知道源表的行数，能否在程序中对行数进行限制，是不是能提高运行速度呢。
7）        参考表在附件中。
敬请各位老师帮助解决，不胜感激！

Zhjonhse

各位老师，帮忙呀，都在周末快乐么

蓝桥玄霜

请见代码。

Zhjonhse

蓝桥玄霜 发表于 2017-7-22 13:09
请见代码。

谢谢！
我得一个个输入，然后，试试。
老师，周末辛苦！

Zhjonhse

老师，您好！
运行有点问题。如下：End With

Sheet1.Activate
[a4].Resize(50000, UBound(Arr1, 2)).ClearContents
gjc = InputBox("请输入关键字：", "复制关键字")
If gjc = "" Then MsgBox "关键字不能为空": Exit Sub
If d.exists(gjc) Then
    t = d(gjc)
    t = Left(t, Len(t) - 1)
    If InStr(t, ",") Then
        aa = Split(t, ",")
        For j = 0 To UBound(aa)

            Cells(j + 4, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, aa(j), 0)
再说明下：我的源库里面有日期、文本、时间和数字格式，是不是这些在作怪呢。
当运行到上面最后一行时，出错了，错误代码：13，显示类型不匹配。

请指教！ 谢谢老师！

Zhjonhse

请老师，指点迷津，如果我的表格名称是“17”，上面的 Arr1 = .sheets(1) 是不是将.sheets(1) 改成.(17)?

请老师答疑！谢谢！

清@清

上面这些代码，代表什么，求指教

Zhjonhse

我也是学习中

Zhjonhse

老师，您好！

End With

Sheet1.Activate
[a4].Resize(50000, UBound(Arr1, 2)).ClearContents
gjc = InputBox("请输入关键字：", "复制关键字")
If gjc = "" Then MsgBox "关键字不能为空": Exit Sub
If d.exists(gjc) Then
    t = d(gjc)
    t = Left(t, Len(t) - 1)
    If InStr(t, ",") Then
        aa = Split(t, ",")
        For j = 0 To UBound(aa)

            Cells(j + 4, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, aa(j), 0)


程序运行到上面最后一行，停止了，并显示：错误代码为13， 类型不匹配。

请老师告知是什么问题啊。

谢谢！

蓝桥玄霜

Zhjonhse 发表于 2017-7-22 15:07
老师，您好！
运行有点问题。如下：End With

请仔细核对代码的每一个字符。
抄写代码是学习编程的必要过程。
编程需要仔细、严谨，不能马马虎虎。
或者上传出错的附件看看。