|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub hebing()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("合并表")
.UsedRange.Offset(2) = Empty
ar = .Range("a1:w50000")
For j = 1 To UBound(ar, 2)
If Trim(ar(1, j)) <> "" Then
d(Trim(ar(1, j))) = j
End If
If Trim(ar(2, j)) <> "" Then
dc(Trim(ar(2, j))) = j
End If
Next j
n = 2
br = Sheets("个人贷款").[a1].CurrentRegion
For i = 2 To UBound(br)
If Trim(br(i, 1)) <> "" Then
n = n + 1
For j = 1 To UBound(br, 2)
m = d(Trim(br(1, j)))
If m <> "" Then
ar(n, m) = br(i, j)
End If
Next j
End If
Next i
br = Sheets("公司贷款").[a1].CurrentRegion
For i = 2 To UBound(br)
If Trim(br(i, 1)) <> "" Then
n = n + 1
For j = 1 To UBound(br, 2)
m = dc(Trim(br(1, j)))
If m <> "" Then
ar(n, m) = br(i, j)
End If
Next j
End If
Next i
.Range("a1:w50000") = ar
End With
MsgBox "OK!"
End Sub
|
|