请教老师一个问题——从一个工作薄获取对应数据到另一个工作薄

68866216

老师好，请问这种操作如何实现？我想通过VBA自动实现实现一下两点功能：
1 获取工作薄2中的后面4列的数据填入工作薄1中对应的位置。
2 实现点击每个栏的标题能实现正/反排序
不知道如何做？请老师帮助我一下 BOOK.rar (277.45 KB, 下载次数: 35)

2011-4-20 19:22 上传

点击文件名下载附件

doitbest

Public Sub eee()
ReDim ar(1 To 4, 1 To Sheet1.UsedRange.Rows.Count)
Set range1 = Workbooks("2.xls").Sheets(1).UsedRange
On Error Resume Next
For Each x In Range([a2], [a2].End(xlDown))
n = n + 1
ar(1, n) = IIf(Err = 0, Application.VLookup(x, range1, 13, 0), "")
ar(2, n) = IIf(Err = 0, Application.VLookup(x, range1, 14, 0), "")
ar(3, n) = IIf(Err = 0, Application.VLookup(x, range1, 15, 0), "")
ar(4, n) = IIf(Err = 0, Application.VLookup(x, range1, 16, 0), "")
Next
[w2].Resize([a2].End(xlDown).Row - 1, 4) = Application.Transpose(ar)

End Sub

68866216

感谢您的帮助，但在我怎么运行时，会提示下标越界呢？？？这是为什么呢？

68866216

需要说明一点的是两个表中的数据个数是不一样多的，并且两个表中的数据关系在添加过程中不能弄错的

lenghonghai

Private Sub CommandButton1_Click()
Dim wb As Workbook, arr1, arr2, arr(1 To 10000, 1 To 4), m&
arr1 = Range("a2:v" & Range("a65536").End(xlUp).Row).Value
Set wb = GetObject(ThisWorkbook.Path & "\2.xls")
arr2 = wb.Worksheets(1).Range("a2:p" & wb.Worksheets(1).Range("a65536").End(xlUp).Row).Value
For i = 1 To UBound(arr1)
        m = m + 1
        For j = 1 To UBound(arr2)
        If arr2(j, 1) = arr1(i, 1) Then
            For k = 13 To 16
                arr(m, k - 12) = arr2(j, k)
            Next k
        Exit For
        End If
    Next j
Next i
Range("w2").Resize(m, 4) = arr
End Sub

doitbest

修改了一些
Public Sub eee()
ReDim ar(1 To 4, 1 To Sheet1.UsedRange.Rows.Count)
Set range1 = Workbooks("2.xls").Sheets(1).UsedRange
On Error Resume Next
For Each x In Range([a2], [a2].End(xlDown))
rel = Application.Match(x, range1, 0)
n = n + 1
ar(1, n) = IIf(Err.Number = 0, Application.VLookup(x, range1, 13, 0), "")
ar(2, n) = IIf(Err.Number = 0, Application.VLookup(x, range1, 14, 0), "")
ar(3, n) = IIf(Err.Number = 0, Application.VLookup(x, range1, 15, 0), "")
ar(4, n) = IIf(Err.Number = 0, Application.VLookup(x, range1, 16, 0), "")
Err.Number = 0
Next
[w2].Resize([a2].End(xlDown).Row - 1, 4).ClearContents
[w2].Resize([a2].End(xlDown).Row - 1, 4) = Application.Transpose(ar)
End Sub

doitbest

上传了个附件，我使用正常，就是有点慢

doitbest

版主的程序取数有问题啊

68866216

非常感谢！我试一下

68866216

怎么还是下标越界啊？劳驾您把*.xls文档上传一下，拜托了