|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
建议参照VBA
Sub FBHZ()
Dim arr, brr, d As Object, wb As Workbook, sht As Worksheet
Dim i As Integer, k, m As Integer
Dim lc As Integer, myPath As String, myFileName As String
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each sht In Sheets
sht.UsedRange.Offset(2, 0).Clear
Next
Set wb = Workbooks.Open(ThisWorkbook.Path & "\Data.xls")
ThisWorkbook.Activate
For Each sht In wb.Sheets
arr = sht.UsedRange
For i = 1 To UBound(arr, 2)
If Not d.exists(arr(1, i)) Then
Set d(arr(1, i)) = sht.Cells(3, i).Resize(UBound(arr) - 2)
Else
Set d(arr(1, i)) = Union(d(arr(1, i)), sht.Cells(3, i).Resize(UBound(arr) - 2))
End If
Next
k = d.keys
For i = 0 To d.Count - 1
With Sheets(k(i))
brr = .Cells(1, 1).Resize(1, .Range("IV1").End(xlToLeft).Column)
m = 0
For j = 1 To UBound(brr, 2)
If d.exists(brr(1, j)) Then
m = m + 1
If m = 1 Then d(brr(1, j)).Copy .Cells(65536, j).End(3).Offset(1)
End If
Next
End With
Next
d.RemoveAll
Next
wb.Close
Application.ScreenUpdating = True
MsgBox "结束"
End Sub
论坛上的,适用于2003
或者http://club.excelhome.net/viewthread.php?tid=446463&highlight=%BB%E3%D7%DC
dg831451的帖子
[ 本帖最后由 zaq123 于 2009-6-13 15:56 编辑 ] |
|