|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub QQ()
- Dim arr, i%, j%, s$, r%, brr, x%, s1$, rng As Range
- For Each rng In [c1:f1]
- s1 = s1 & Application.Match(rng, Sheets("源数据").[b1:h1], 0)
- Next
- With Sheets("源数据")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- .Range("a1:a" & r).Copy .[i1]
- For i = 2 To r
- s = .Cells(i, "i").Value
- j = .Cells(i, "i").MergeArea.Count
- .Cells(i, "i").UnMerge
- .Range(.Cells(i, "i"), .Cells(i + j - 1, "i")).Value = s
- i = i + j - 1
- Next
- arr = .Range("b1:i" & r)
- .Columns("i").Clear
- End With
- r = Cells(Rows.Count, 2).End(xlUp).Row
- brr = Range("a1:f" & r)
- For i = 2 To UBound(brr)
- For j = 2 To UBound(arr)
- s = Application.Lookup("々", Range("a2:a" & i)) & brr(i, 2)
- If s = arr(j, 8) & arr(j, 1) Then
- For x = 3 To 6
- brr(i, x) = arr(j, Mid(s1, x - 2, 1))
- Next
- End If
- Next
- Next
- Range("a1:f" & r) = brr
- End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-8-7 15:56
楼主