Option Explicit
Sub Test()
Dim RngA As Range, RngUrl As Range, rngtag As Range, c As Range
Dim FA As String
Application.ScreenUpdating = False
Set RngA = Range(Cells(1), Cells.Find("*", Cells(1), -4123, 2, 1, 2, False))
With RngA
Set RngUrl = .Find("https://", LookIn:=xlValues)
If Not RngUrl Is Nothing Then
FA = RngUrl.Address
Do
Set c = RngUrl.Offset(1, 1)
Set rngtag = Range(c, c.End(xlDown))
RngUrl.Offset(, 3).ClearContents
RngUrl.Offset(, 4).ClearContents
For Each c In rngtag
Select Case c.Value
Case Cells(4).Value
RngUrl.Offset(, 3).Value = RngUrl.Offset(, 3).Value & "," & c.Offset(, 1).Value
Case Cells(5).Value
RngUrl.Offset(, 4).Value = RngUrl.Offset(, 4).Value & "," & c.Offset(, 1).Value
Case Else
Exit For
End Select
Next c
RngUrl.Offset(, 3).Value = Mid(RngUrl.Offset(, 3).Value, 2)
RngUrl.Offset(, 4).Value = Mid(RngUrl.Offset(, 4).Value, 2)
Set RngUrl = .FindNext(RngUrl)
Loop While Not RngUrl Is Nothing And RngUrl.Address <> FA
End If
End With
Columns("D:E").AutoFit
Application.ScreenUpdating = True
End Sub
|