|
|
VBA
Sub 筛选复制()
Application.CutCopyMode = False
Range("B:B").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Range("H2"), CopyToRange:=Range("H2"), Unique:=True
End Sub
Sub 合并()
Dim rngCell As Range, rngResult As Range, s As String, c As Range, i%
Dim strFirstAddress As String
For i = 3 To [h1048476].End(xlUp).Row
Set rngCell = Range("B2:B16").Find(What:=Cells(i, 8), After:=Range("B2:B16").Cells(1), LookIn:=xlValues, LookAt:=xlPart)
If Not rngCell Is Nothing Then
strFirstAddress = rngCell.Address
Set rngResult = rngCell
Do
Set rngResult = Application.Union(rngResult, rngCell)
Set rngCell = Range("B2:B16").FindNext(rngCell)
Loop While rngCell.Address <> strFirstAddress
rngResult.Offset(, 2).Select
If TypeName(Selection) = "Range" Then
For Each c In Selection
s = s & "/" & c.Value
Next
End If
Cells(i, 9) = VBA.Mid(s, 2, Len(s))
End If
s = ""
Next i
Set rngCell = Nothing
Set rngResult = Nothing
End Sub
单元格显示多个查询结果.zip
(18.73 KB, 下载次数: 129)
|
|
