[已解决]有请高手帮忙

kkmlm

附件为一段查找并复制的代码，可以代替繁琐的手工复制、粘贴等工作，这段代码处理少量数据可能还没什么问题，但是当要处理大量数据时可能会有些吃力了，请高手们帮忙优化一下。
还有一个很大不足就是不能跨工作薄工作，请高手们指点一下该如何更改代码才可以实现跨工作薄自动查找并复制、粘贴，例如sheet2中的数据是在其他工作薄的第一个sheet中，而且sheet名也不一定是"sheet1"。

附件中的代码是在2007版本中编写的，在2003版中运行可能会报错哦。

基本要求是在一个最终的表格（例如：book1中的sheet1）里有定制好列表名，添加一个按钮可以实现选择并打开的其他工作薄（例如：book2和book3中的第一个sheet，这两个sheet的名称不一样的）里按最终表格列表名的排序复制相关的数据并粘贴过来，有一点比较麻烦的就是原始数据列表名排列次序与最终表格的列表名排列次序是不一致的，只要改动最终表格的列表名，即可生成按新的列表名称复制相关的数据（book2和book3中的原始数据的首行与末行有些是空值也必须考虑进去）。

YiiaXMBk.rar (11.12 KB, 下载次数: 11)

2010-11-30 21:32 上传

点击文件名下载附件
有请高手帮忙

[此贴子已经被作者于2010-11-30 21:31:58编辑过]

最佳答案

月排行榜 / 总排行榜

龙猫

2010-11-30 23:49

Sub 按钮2_Click()
    Dim i, k, l, m, x, y, rng
    l = [iv1].End(xlToLeft).Column
m = Sheet2.Cells.SpecialCells(xlCellTypeLastCell).Row
    For i = 1 To l
        rng = Sheet2.Range("1:1").Find(Cells(1, i), LookIn:=xlValues).Column
        If rng <> "" Then
            Cells(2, i).Resize(m - 1, 1) = Sheet2.Cells(2, rng).Resize(m - 1, 1).Value
        End If
    Next
End Sub

44这个

跳转到最佳答案楼层

龙猫

Sub 按钮2_Click()
    Dim i, k, l, m, x, y, rng
    l = [iv1].End(xlToLeft).Column
m = Sheet2.Cells.SpecialCells(xlCellTypeLastCell).Row
    For i = 1 To l
        rng = Sheet2.Range("1:1").Find(Cells(1, i), LookIn:=xlValues).Column
        If rng <> "" Then
            Cells(2, i).Resize(m - 1, 1) = Sheet2.Cells(2, rng).Resize(m - 1, 1).Value
        End If
    Next
End Sub

44这个