|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub tqu1()
Dim i, j, k, irow, icolumn, irow1, icolumn1, m, s, t, p
Dim ar, br, cr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
irow = Sheets("数据表").[a65536].End(xlUp).Row
icolumn = Sheets("数据表").[iv2].End(xlToLeft).Column
ar = Sheets("数据表").Range("a1:k" & irow)
ar(3, 11) = ar(3, 1): ar(3, 1) = ""
For i = 4 To irow
If ar(i, 1) <> "" And ar(i, 2) = "" Then
ar(i, 11) = ar(i, 1): ar(i, 1) = ""
End If
If ar(i, 11) = "" And ar(i - 1, 11) <> "" Then
ar(i, 11) = ar(i - 1, 11)
End If
For j = 2 To icolumn
If ar(i, j) <> "" Then
If Not d.exists(ar(i, j)) Then
d(ar(i, j)) = ar(i, 11) & ar(i, 1) & "," & ar(2, j)
Else
d(ar(i, j)) = d(ar(i, j)) & "," & ar(i, 11) & ar(i, 1) & "," & ar(2, j)
End If
End If
Next
Next
irow1 = Sheets("查询").[a65536].End(xlUp).Row
icolumn1 = Sheets("查询").[iv2].End(xlToLeft).Column
br = Sheets("查询").[a1].Resize(irow1, icolumn1)
ReDim cr(1 To irow1, 1 To 20)
For k = 3 To irow1
m = m + 1
s = WorksheetFunction.Substitute(d(br(k, 1)), ",", "")
t = Len(d(br(k, 1))) - Len(s) + 1
If t > 1 Then
For p = 1 To t
cr(m, p) = Split(d(br(k, 1)), ",")(p - 1)
Next
End If
Next
Sheets("查询").[b3].Resize(500, icolumn1).ClearContents
Sheets("查询").[b3].Resize(m, 20) = cr
MsgBox "ok"
End Sub |
|