标题行相同，数据自动复制

LMY123

跨工作薄
http://club.excelhome.net/thread-971114-1-1.html
本工作薄
http://club.excelhome.net/thread-1221723-1-1.html

http://club.excelhome.net/forum. ... &tid=1352435&page=1

如何按标题行导入相应列数据-同薄多表.rar (34.46 KB, 下载次数: 95)

2017-9-1 12:34 上传

点击文件名下载附件

补充内容 (2017-11-7 10:16):
http://club.excelhome.net/thread-1352435-2-1.html

SQL与字典方法

补充内容 (2017-11-22 15:41):
SQL跨工作薄：http://club.excelhome.net/forum. ... ead&tid=1289767

补充内容 (2017-11-22 15:47):
http://club.excelhome.net/forum. ... ertype=2&page=2

补充内容 (2017-11-22 16:23):
字典同薄：http://club.excelhome.net/thread-1250134-1-1.html

补充内容 (2018-1-27 11:17):
多薄单表的：http://club.excelhome.net/thread-1394629-1-1.html

补充内容 (2018-1-27 14:53):
同薄多表：http://club.excelhome.net/thread-898218-1-1.html

补充内容 (2018-3-22 15:40):
标题行有合并单元格
http://club.excelhome.net/forum. ... ead&tid=1402588

补充内容 (2018-8-18 17:22):
http://club.excelhome.net/forum. ... ead&tid=1431187

补充内容 (2018-12-13 17:44):
http://club.excelhome.net/thread-1451319-1-2.html
字典法

补充内容 (2018-12-23 21:50):
Sub 标题行相同_数据自动复制_字典法_多条件()
    Set 字典 = CreateObject("scripting.dictionary")
    条件1 = "债券卖出": 条件2 = "债券买入"
    源数组 = Sheet1.Range("a1").CurrentRegion
    条件数组 = Sheet2.Range("a1").CurrentRegion
    ReDim 结果数组(1 To 20000, 1 To UBound(条件数组, 2))
    For 列 = 1 To UBound(源数组, 2)
        字典(源数组(1, 列)) = 列
    Next 列
    For 行 = 2 To UBound(源数组)
        If 源数组(行, 10) = 条件1 Or 源数组(行, 10) = 条件2 Then
            计数器 = 计数器 + 1
            For 列 = 1 To UBound(条件数组, 2)
                字典列 = 字典(条件数组(1, 列))
                结果数组(计数器, 列) = 源数组(行, 字典列)
            Next 列
        End If
    Next 行
    Sheet2.Range("a2").Resize(计数器, UBound(结果数组, 2)) = 结果数组
End Sub

乐乐2006201505

在你链接帖子代码基础上修改的。试试看可以了吗。将下面代码拷入新建模块中，再在工作表中添加按钮。
不好意思，没有看清楚，这是你推荐的帖子，不是求助帖子。同时希望你能推荐更多有用的帖子地址。
Sub CommandButton1_Click()
    Dim Wb As Workbook
    Dim Temp As String
    Dim r&, j%
    Call 宏1
    Application.ScreenUpdating = False
    Temp = ThisWorkbook.Path & "\需导入相应字段的数据文件.xls"
    Set Wb = GetObject(Temp)
        For Each sh In Wb.Sheets
            With sh
                r = .[a65536].End(3).Row
                For j = 1 To 5
                    Set cel = Range("a1:j1").Find(.Cells(1, j), , , 1)
                    If Not cel Is Nothing Then
                    r1 = Cells(65536, cel.Column).End(3).Row + 1
                        .Cells(2, j).Resize(r - 1).Copy Cells(r1, cel.Column)
                    End If
                Next
            End With
        Next
        Wb.Close False
    Set Wb = Nothing
    Application.ScreenUpdating = True
End Sub

凤翔时代

乐乐2006201505 发表于 2017-9-3 00:13
在你链接帖子代码基础上修改的。试试看可以了吗。将下面代码拷入新建模块中，再在工作表中添加按钮。
不好 ...

感谢两位的分享，学习中

宝玉66

感谢老师的帮助。

LMY123

ADO,多薄字段相同，顺序不同

http://club.excelhome.net/forum. ... 1&extra=#pid9615598
本薄，字典法

http://club.excelhome.net/thread-1221723-1-1.html


http://club.excelhome.net/thread-1272546-1-1.html

mx200200

好难啊，收下，好好学习