[حل شده] ادغام نتیجه اطلاعات تکراری

[sunstar]

سلام علیکم
فرض کنید در ستون a یک سری نام در حدود 5000نفر درج شده و درستون b نام خانوادگی این افراد درج شده است میخواهیم تابعی در سلهای ستون c بنویسیم که در صورتیکه که اسامی در سل های ستون a تکراری باشد اطلاعات سل b آنها باهم ادغام ودر سل c آنها درج گردد.مثلاً در چندین سل ستون a به صورت پراکنده نام علی داریم و در سل b آنها نام خانوادگی مختلفی مثل علوی ؛ رجبی؛ حسینی درج شده است .میخواهیم تابعی در ستون c درج کنیم که در مقابل هر اسم علی در ستون aدر ستون c فقط نتیجه ادغام نام خانوادگیها درج شده یاشد مثل علوی؛رجبی؛حسینی.
باتشکر فراوان

[amir_ts]

با سلام
این فایل رو ببینید اگر بخواهید در یک سل همه اسامی رو ادغام کنید باید از عملگر & یا تابع concatenate استفاده کنید و یکسری ستون ها رو مخفی کنید که برای 5000 ردیف کار جالبی به نظر نمیرسه .

[Amir Ghasemiyan]

سلام دوست عزیز
بهترین و ساده ترین راهی که من به نظرم میرسه استفاده از VBA هست
در این کد که خدمتتون ارائه میکنم شما نیاز به یک ستون کمکی دارین. در این ستون شما باید نام های موجود رو بصورت یونیک (بدون تکرار) وارد کنید. اگر ایجاد نام بصورت یونیک رو بلد نیستین بگین تا راهنماییتون کنم. من از ستون D برای اینکار کمک گرفتم

Sub ExcelIran()
Dim q() As Variant
Dim cel As Range, rng As Range
For Each rng In Range("D1:D4")
    i = 0
    For Each cel In Range("A1:A9")
        If cel.Value = rng.Value Then
            f = f & ";" & cel.Offset(0, 1).Value
            ReDim Preserve q(i)
            q(i) = cel.Row
            i = i + 1
        End If
    Next cel
    f = Right(f, Len(f) - 1)
    For Each w In q
        Cells(w, 3) = f
    Next w
    f = ""
Next rng
End Sub

هر جایی از کد رو که متوجه نشدید بگین تا توضیح بدم

[sunstar]

سلام علیکم
خواهشمندم درمورد یونیک اسامی توضیح بدید .اگر درمورد کد های که ثبت کردید توضیح بدید ممنون میشم .اگر یک فایل نمونه هم باشه بیشتر ممنونتون میشم هزازان درود وسپاس

[iranweld]

با سلام

در فایل پیوست اسامی که مشابه هستن فامیلی آنها در سلولهای روبروی آن قید میگردد.

Sub test()

Macro1

Z = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row

For I = 1 To Z

For J = I + 1 To Z

If Range("A" & I) = Range("A" & J) And Range("A" & J).Font.ColorIndex <> 3 Then

K = Application.WorksheetFunction.CountA(Sheet1.Range(I & ":" & I)) + 1

Range("A" & J).Font.ColorIndex = 3

Cells(I, K) = Range("B" & J)

End If

Next

Next

End Sub 

[sunstar]

استاد بزرگوار
از پاسخ جنابعالی ممنونم فقط در خصوص ادغام اطلاعات که هزمان با اجرای ماکرو صورت گیرد خواهشمندم راهنمایی فرمائید

[iranweld]

استاد بزرگوار
از پاسخ جنابعالی ممنونم فقط در خصوص ادغام اطلاعات که هزمان با اجرای ماکرو صورت گیرد خواهشمندم راهنمایی فرمائید

منظور شما از ادغام چیست؟ در یک سلول تمامی فامیلی هایی که اسامی یکجور دارند، مرتب گردد؟

Sub test()

Macro1

Z = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row

Range("c1:c" & Z).ClearContents

For i = 1 To Z

For j = i + 1 To Z

If Range("A" & i) = Range("A" & j) And Range("A" & j).Font.ColorIndex <> 3 Then

Range("A" & j, "b" & j).Font.ColorIndex = 3

If Range("c" & i) = "" Then

Range("c" & i) = Range("b" & i)
End If

Range("c" & i) = Range("c" & i) & " ; " & Range("B" & j)

Columns("c:c").EntireColumn.AutoFit

End If

Next

Next

End Sub 

[Amir Ghasemiyan]

سلام علیکم
خواهشمندم درمورد یونیک اسامی توضیح بدید .اگر درمورد کد های که ثبت کردید توضیح بدید ممنون میشم .اگر یک فایل نمونه هم باشه بیشتر ممنونتون میشم هزازان درود وسپاس

سلام دوست عزیز
شما باید یک کپی از اسامیتون بگیرید و در ستون D قرار بدین. بعد از تب data گزینه remove dublicates رو بزنین. اسامی ستون D بصورت یونیک در خواهد آمد

اگر لیست فامیل ها جلوی یکی از اسم ها ثبت بشه براتون کفایت میکنه روش دوستمون جناب آقای iranweld رو انجام بدین سریعتر به جواب میرسید. منتها دقت کنید که اسامی که تکرار نشده باشند در ستون C فامیلی ثبت نخواهد شد.

اما کدی که من نوشتم به این صورت عمل میکنه:
تک تک اسم هایی که در ستون D هستند رو در لیست ستون A بررسی کرده و اگر مشابه اسم ستون D باشد شماره ردیف آن و نام فامیل آن را در حافظه موقت ثبت میکند و پس از آنکه تمام اسم های ستون A تمام شدند در حلقه بعد در تمامی شماره ردیف هایی که در حافظه موقت ثبت شده اند فامیل ها را وارد میکند

[sunstar]

از اساتید بزرگوار بینهایت ممنونم