با سلام
خدمت شما ، امیدوارم به دردتون بخوره
بدون محدودیت سطر و ستون
فقط فاصله کلمه S cripting رو در متن بردارید و سپس استفاده کنید
خروجی به این صورت میشه
[
کد:
'With Respect
'Here You Are
Sub GetUniquesAndFindCategory()
Dim cel As Range, cel2 As Range
Dim cat As String
sep = "_"
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("S cripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Columns("F:F").Select
Selection.ClearContents
Range("F2").Resize(d.Count) = Application.Transpose(d.keys)
'Option For Delete Blanks
Columns("F:F").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Range("A1").Select
For Each cel In Range("F1:F" & lr)
For Each cel2 In Range("A2:A" & lr)
If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
Next cel2
cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))
cat = ""
Next cel
Cells.Select
Cells.EntireColumn.AutoFit
With Selection
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
Columns("G:G").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
End Sub
علاقه مندی ها (Bookmarks)