Sub 銀行合并()
Application.ScreenUpdating = False
Dim wh As Worksheet, sh As Worksheet
Dim last_column%, str As String, last_row As Integer, n As Integer, a As Integer
Dim crr(), arr(), brr()
Set wh = Worksheets("4合賬草稿")
With wh
last_column = .Cells(1, Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(1, 1), .Cells(1, last_column))
End With
For Each sh In Worksheets
If sh.Name = wh.Name Then Exit For
With sh
last_column = .Cells(1, Columns.Count).End(xlToLeft).Column
last_row = .Cells(Rows.Count, 1).End(xlUp).Row
brr = .Range(.Cells(1, 1), .Cells(last_row, last_column))
For i = 2 To UBound(brr)
n = n + 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To n)
For k = 1 To UBound(arr, 2)
For j = 1 To UBound(brr, 2)
If InStr(1, Trim(arr(1, k)), Trim(brr(1, j)), vbBinaryCompare) > 0 Then
crr(k, n) = brr(i, j)
End If
Next j
Next k
Next i
End With
Next
wh.Range("a2:k65536").ClearContents
wh.Range("a2").Resize(UBound(crr, 2), 11) = Application.Transpose(crr)
Application.ScreenUpdating = True
End Sub
|
