[حل شده] وارد کردن اطلاعات متناظر با یک ستون در ستون بعدی

[M_N_Bokaei]

با سلام
دو ستون در اکسل دارم، ستون اول حاوی یک سری کد و ستون دوم حاوی کد های متناظر آن، در هر دو ستون تکراری وجود دارد ولی ترکیب دو ستون یکتا می باشد. (مانند جدول ذیل)

کد	کد متناظر
A	1
B	2
C	3
A	2
C	4
B	3
A	5
D	6
D	2

حال می خوام در شیت دیگر در ستون اول اطلاعات ستون اول (کد) به صورت یکتا قرار بگیرد. و در سلول متناظر آن کدهای ستون دوم (کد متناظر) با "-"از هم جدا شده و قرار بگیرد.
به مثل جدول ذیل

کد	کدهای متناظر
A	1-2-5
D	2-6

کارهایی که کردم این بوده: (شیت Data صفحه است که جدول اصلی در آن است، شیت Out صفحه است که میخواهم اطلاعات در آن وارد شود)

    Sheets("Data").Select
    Dim LC As Integer
    LC = Cells(Rows.Count, 1).End(xlUp).Row
    Columns("A:A").Select
    Selection.Copy
    Sheets("Out").Select
    Columns("A:A").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$" & LC).RemoveDuplicates Columns:=1, Header:=xlNo

کد های این موضوع را هم دیدم ولی متوجه نشدم چطوری باید این کار رو انجام بدم.
لطف می کنید راهنمایی کنید؟

[mahdi2013]

با سلام
خدمت شما ، امیدوارم به دردتون بخوره
بدون محدودیت سطر و ستون
فقط فاصله کلمه 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

[M_N_Bokaei]

با سلام
خدمت شما ، امیدوارم به دردتون بخوره
بدون محدودیت سطر و ستون
فقط فاصله کلمه S cripting رو در متن بردارید و سپس استفاده کنید
خروجی به این صورت میشه
[ATTACH=CONFIG]16186[/ATTACH]

[

'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

با سلام و تشکر از شما
چند مسئله دارم فقط:
1- اول اینکه هرکاری میکنم، نمی تونم بهش بفهمونم توی یک شیت دیگه خروجی را (به جای ستون F , G همون شیت) وارد کند.
2- سطر شامل عبارت ذیل ارور میدهد ولی خروجی اش درست است!

cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))

[mahdi2013]

خدمت شما
چنانچه به جواب رسیدین کلید Solved فراموش نشه .

- - - Updated - - -

'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
        Worksheets("Sheet2").Select
        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 Worksheets("Sheet1").Range("A2:A" & lr)
                If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
            Next cel2
            Worksheets("Sheet2").Select
            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

[M_N_Bokaei]

با سپاس و تشکر فراوان از شما...

خدمت شما
چنانچه به جواب رسیدین کلید Solved فراموش نشه .

- - - Updated - - -

'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
        Worksheets("Sheet2").Select
        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 Worksheets("Sheet1").Range("A2:A" & lr)
                If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
            Next cel2
            Worksheets("Sheet2").Select
            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