ادغام مقادیر منحصر به فرد را در اکسل

با سلام خدمت کاربران عزیز آی تی سواد

اگر یک لیست طولانی از مقادیر داشته باشم که با برخی داده‌های تکراری پر شده‌اند ، اکنون می‌خواهم تنها مقادیر منحصر به فرد را پیدا کنم و سپس آن‌ها را به یک سلول واحد تبدیل کنم . چگونه می‌توانم به سرعت و به راحتی ادغام مقادیر منحصر به فرد را در اکسل را انجام دهیم ؟

ادغام مقادیر منحصر به فرد را در اکسل با کد VBA

۱. کلیدهای Alt + F11 را فشار دهید تا پنجره Microsoft Visual Basic for Applications باز شود .

۲. در پنجره Microsoft Visual Basic for Applications بر رویInsert > Module کلیک کنید و سپس از زیر کد VBA را کپی و در درون پنجره ماژول قراردهید .

Function ConcatUniq(xRg As Range, xChar As String) As String
'updateby Extendoffice 20151228
    Dim xCell As Range
    Dim xDic As Object
    Set xDic = CreateObject("Scripting.Dictionary")
    For Each xCell In xRg
        xDic(xCell.Value) = Empty
    Next
    ConcatUniq = Join$(xDic.Keys, xChar)
    Set xDic = Nothing
End Function

Function ConcatUniq(xRg As Range, xChar As String) As String

'updateby Extendoffice 20151228

Dim xCell As Range

Dim xDic As Object

Set xDic = CreateObject("Scripting.Dictionary")

For Each xCell In xRg

xDic(xCell.Value) = Empty

ConcatUniq = Join$(xDic.Keys, xChar)

Set xDic = Nothing

End Function

۳. سپس به کاربرگ برگردید , و این فرمول را در یک سلول خالی وارد کنید : (“,”,ConcatUniq (A1:A17= و کلید Enter را بزنید تا جواب را ببینید.

نکته : در فرمول بالا ،A1:A17 سلول‌هایی هست که شما می‌خواهید ادغام کنید، و کاما ” ،” جدا کننده است که شما برای جدا کردن مقادیر ترکیب‌شده نیاز دارید ، شما می‌توانید آن‌ها را به نیاز خود تغییر دهید .

لیست مقادیر منحصر به فرد براساس مقادیر با کد VBA

در مورد دیگر ، شما یک سری اطلاعات دارید که شامل دو ستون است، و حالا ، شما می‌خواهید فقط مقادیر منحصر به فرد را فهرست کنید و مقادیر متناظر خود را از ستون دیگری برای رسیدن به نتیجه مانند عکس زیر انتخاب کنید ، آیا روش خوبی برای انجام این کار در اکسل وجود دارد؟

۱. کلیدهای Alt + F11 را فشار دهید تا پنجره Microsoft Visual Basic for Applications باز شود .

Sub test()
'updateby Extendoffice 20151228
    Dim xRg As Range
    Dim xArr As Variant
    Dim xCell As Range
    Dim xTxt As String
    Dim I As Long
    Dim xDic As Object
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("لطفا محدوده موردنظر را انتخاب کنید", "آی تی سواد", xTxt, , , , , 8)
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub
    If xRg.Areas.Count > 1 Then
        MsgBox "چند تا محدوده را پشتیبانی نمی کند", , "آی تی سواد"
        Exit Sub
    End If
    If xRg.Columns.Count <> 2 Then
        MsgBox "تنها دو ستون باید انتخاب شود", , "آی تی سواد"
        Exit Sub
    End If
    xArr = xRg
    Set xDic = CreateObject("Scripting.Dictionary")
    xDic.CompareMode = 1
    For I = 1 To UBound(xArr)
        If Not xDic.Exists(xArr(I, 1)) Then
            xDic.Item(xArr(I, 1)) = xDic.Count + 1
            xArr(xDic.Count, 1) = xArr(I, 1)
            xArr(xDic.Count, 2) = xArr(I, 2)
        Else
            xArr(xDic.Item(xArr(I, 1)), 2) = xArr(xDic.Item(xArr(I, 1)), 2) & "," & xArr(I, 2)
        End If
    Next
    Sheets.Add.Cells(1).Resize(xDic.Count, 2).Value = xArr
End Sub

Sub test()

'updateby Extendoffice 20151228

Dim xRg As Range

Dim xArr As Variant

Dim xCell As Range

Dim xTxt As String

Dim I As Long

Dim xDic As Object

On Error Resume Next

xTxt = ActiveWindow.RangeSelection.Address

Set xRg = Application.InputBox("لطفا محدوده موردنظر را انتخاب کنید", "آی تی سواد", xTxt, , , , , 8)

Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)

If xRg Is Nothing Then Exit Sub

If xRg.Areas.Count > 1 Then

MsgBox "چند تا محدوده را پشتیبانی نمی کند", , "آی تی سواد"

Exit Sub

End If

If xRg.Columns.Count <> 2 Then

MsgBox "تنها دو ستون باید انتخاب شود", , "آی تی سواد"

Exit Sub

End If

xArr = xRg

Set xDic = CreateObject("Scripting.Dictionary")

xDic.CompareMode = 1

For I = 1 To UBound(xArr)

If Not xDic.Exists(xArr(I, 1)) Then

xDic.Item(xArr(I, 1)) = xDic.Count + 1

xArr(xDic.Count, 1) = xArr(I, 1)

xArr(xDic.Count, 2) = xArr(I, 2)

Else

xArr(xDic.Item(xArr(I, 1)), 2) = xArr(xDic.Item(xArr(I, 1)), 2) & "," & xArr(I, 2)

End If

Sheets.Add.Cells(1).Resize(xDic.Count, 2).Value = xArr

End Sub

۳. سپس کلید F5 را فشار دهید تا این کد را اجرا کنید، و یک پنجره فوری ظاهرشود تا به شما یاد آوری کند که محدوده داده‌ها را که می‌خواهید براساس مقادیر منحصر به فرد ایجاد کنید را انتخاب کنید .

۴. روی OK کلیک کنید ، مقادیر منحصر به فرد استخراج‌شده و مقادیر متناظر آن‌ها در یک ستون دیگر در یک کاربرگ جدید تبدیل شده‌است

ترجمه شده از سایت www.extendoffice.com

ممنون از همراهی شما کاربران عزیز آی تی سواد

اشتراک گذاری

بیشتر

آی تی سواد | ادغام مقادیر منحصر به فرد را در اکسل

با سلام خدمت کاربران عزیز آی تی سواد

ادغام مقادیر منحصر به فرد را در اکسل با کد VBA

لیست مقادیر منحصر به فرد براساس مقادیر با کد VBA

ممنون از همراهی شما کاربران عزیز آی تی سواد

دیدگاهتان را بنویسید لغو پاسخ