[حل شده] مقایسه اطلاعات

[elman1368]

با سلام خدمت دوستان گرامی
من یه فایل دارم که چند تا ستون داره که تعداد ستون ها کم و زیاد میشه و همین طور اسامی داخل ستون ها هم کم و زیاد میشه
میخوام ستون 1 با ستون 2 مقایسه بشه و مشترکات بره در شیت 2 ذخیره بشه و بره ستون 1 و 3 و مجدد مشترکات رو در شیت 2 ذخیره کنه و بره سراغ بعدی
وقتی ستون ها تموم شد ستون یک رو از چزخه مقایسه خارج بکنه و ستون 2 و 3 رو مقایسه کنه و مشترکات رو بریزه تو شیت 2 و بره ستون 2 و 4 رو مقایسه کنه و بره جلو و وقتی تموم شد مجدد بیاد ستون 2 رو از چرخه مقایسه خارج کنه
چند تا نکته مهم
1- نتیجه مقایسه ستون ها رو طوری بنویسه که بشه فهمید که نتیجه کدوم ستون ها هستش
2- تعداد ستون ها کم و زیاد میشه و فرمول نباید به تعداد حساس بشه
3- مقدار ستون ها هم کم و زیاد میشه و فرمول نباید به تعداد حساس بشه(ستون ها امکان داره از یک مورد تا 10000 مورد باشه)
4- مقادیر ستون ها شماره ملی هستش

[M_ExceL]

با سلام خدمت دوستان گرامی
من یه فایل دارم که چند تا ستون داره که تعداد ستون ها کم و زیاد میشه و همین طور اسامی داخل ستون ها هم کم و زیاد میشه
میخوام ستون 1 با ستون 2 مقایسه بشه و مشترکات بره در شیت 2 ذخیره بشه و بره ستون 1 و 3 و مجدد مشترکات رو در شیت 2 ذخیره کنه و بره سراغ بعدی
وقتی ستون ها تموم شد ستون یک رو از چزخه مقایسه خارج بکنه و ستون 2 و 3 رو مقایسه کنه و مشترکات رو بریزه تو شیت 2 و بره ستون 2 و 4 رو مقایسه کنه و بره جلو و وقتی تموم شد مجدد بیاد ستون 2 رو از چرخه مقایسه خارج کنه
چند تا نکته مهم
1- نتیجه مقایسه ستون ها رو طوری بنویسه که بشه فهمید که نتیجه کدوم ستون ها هستش
2- تعداد ستون ها کم و زیاد میشه و فرمول نباید به تعداد حساس بشه
3- مقدار ستون ها هم کم و زیاد میشه و فرمول نباید به تعداد حساس بشه(ستون ها امکان داره از یک مورد تا 10000 مورد باشه)
4- مقادیر ستون ها شماره ملی هستش

سلام،
فایل پیوست رو بررسی کنید.
روی باتن 1 در شیت دوم کلیک کنید.

Sub M_E()
Dim lr, lcol As Long
Dim col, c, ra, r As Long
    lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row
    lcol = Sheets(1).Cells(1, Columns.Count).End(1).Column
    Sheets(2).Range("a2:a" & Rows.Count).ClearContents
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
                For col = 1 To lcol
                    For c = 1 To lcol
                        For ra = 1 To lr
                            For r = 1 To lr
                                If Sheets(1).Cells(ra, col).Column = Sheets(1).Cells(r, c).Column Then
                                    c = c + 1
                                End If
                                If Sheets(1).Cells(ra, col) = Sheets(1).Cells(r, c) Then
                                    Sheets(2).Cells(Rows.Count, 1).End(3).Offset(1, 0) = Chr(211) & Chr(202) & Chr(230) & Chr(228) & _
                                    Sheets(1).Cells(ra, col).Column & Chr(209) & Chr(207) & Chr(237) & Chr(221) & Sheets(1).Cells(ra, col).Row _
                                    & "," & Chr(211) & Chr(202) & Chr(230) & Chr(228) & Sheets(1).Cells(r, c).Column & Chr(209) & Chr(207) & _
                                    Chr(237) & Chr(221) & Sheets(1).Cells(r, c).Row
                                End If
                            Next r
                        Next ra
                    Next c
                Next col
            .ScreenUpdating = True
            .EnableEvents = True
        End With
End Sub

[elman1368]

سلام دوست عزیز
ممنون از جوابتون ولی اونی که من میخواستم این نبود
من یه نمونه فایل میفرستم خدمتتون
نکته مهمش اینه که تعداد سطر ها و ستون ها زیاد میشه و فرمول باید طوری باشه که به این موضوع ارور نده

[M_ExceL]

سلام دوست عزیز
ممنون از جوابتون ولی اونی که من میخواستم این نبود
من یه نمونه فایل میفرستم خدمتتون
نکته مهمش اینه که تعداد سطر ها و ستون ها زیاد میشه و فرمول باید طوری باشه که به این موضوع ارور نده

داخل شیت سه روی باتن 1 کلیک کنید.

Sub M_E()

Dim lr, lr2, lr3, lr4, lcol As Long

Dim c, ra, r, i, n As Long

    With Application
    
        .EnableEvents = False
        .ScreenUpdating = False
        
            Sheets(3).Cells.ClearContents
            
            lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row
            lcol = Sheets(1).Cells(1, Columns.Count).End(1).Column
            
                For c = 2 To lcol
                    For ra = 2 To lr
                        lr2 = Sheets(1).Cells(Rows.Count, c).End(3).Row
                        For r = 2 To lr2
                        
                            If Sheets(1).Cells(ra, 1).Text = Sheets(1).Cells(r, c).Text Then
                            
                                Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0) = Chr(211) & Chr(202) & _
                                Chr(230) & Chr(228) & " " & Mid(Sheets(1).Cells(r, c).EntireColumn.Address, 2, 1) & " , " & _
                                Mid(Sheets(1).Cells(ra, 1).EntireColumn.Address, 2, 1)
                                Sheets(3).Cells(Rows.Count, 2).End(3).Offset(1, 0) = Sheets(1).Cells(r, c)
                                
                            End If
                        Next r
                    Next ra
                Next c
            
            lr3 = Sheets(3).Cells(Rows.Count, 1).End(3).Row
            
            For i = 2 To lr3
                For c = 1 To lcol
                    lr4 = Sheets(1).Cells(Rows.Count, c).End(3).Row
                    For n = 2 To lr4
                    
                        If Sheets(3).Cells(i, 2) = Sheets(1).Cells(n, c) Then
                        
                            Sheets(3).Cells(i, Columns.Count).End(1).Offset(, 1) = Chr(211) & Chr(202) & Chr(230) & Chr(228) & " " & _
                            Mid(Sheets(1).Cells(n, c).EntireColumn.Address, 2, 1)
                            
                        End If
                        
                    Next n
                Next c
            Next i
            
        .ScreenUpdating = True
        .EnableEvents = True
        
    End With
    
End Sub

یا حق.

[elman1368]

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

[elman1368]

دوست عزیز اگه امکانش هست کد رو طوری تعریف کنید که ستون a تا zz رو بشناسه و سطر ها رو هم تا یک میلیون بشناسه مشکلم حل میشه

[M_ExceL]

دوست عزیز اگه امکانش هست کد رو طوری تعریف کنید که ستون a تا zz رو بشناسه و سطر ها رو هم تا یک میلیون بشناسه مشکلم حل میشه

متوجه منظورتون نشدم، در صورت اضافه شدن ستون، کد تا اخرین ستون رو بررسی میکنه، بنده دوباره چک کردم به درستی داره عمل میکنه.
یک بار دیگر دقیق چک بفرمایید. اگر کد رو داخل فایل دیگری تست کردید فایل قرار بدید بررسی کنیم.

[elman1368]

با عرض شرمندگی
این برنامه ای که شما زحمت کشیدید فقط ستون a رو با بقیه ستون ها مقایسه میکنه و تموم میشه درحالی که درخواست من اینکه که بعد از اینکه ستونa با کل ستون ها مقایسه شد از چرخه خارج بشه بعدش بیاد ستونb رو با کل ستون ها مقایسه کنه و ستون b از چزخه خارج بشه و به این صورت تا ستون آخر بره
یه شرح زیر

a با b

a با c

a با d

a با e

a با f

a با g

a با h

b با c

b با d

b با e

b با f

b با g

b با h

c با d

c با e

c با f

c با g

c با h

d با e

d با f

d با g

d با h

e با f

e با g

e با h

f با g

f با h

g با h

در ضمن اگر صلاح بدونید بنده شماره تقدیم کنم تا به صورت تلفنی عرض کنم

[M_ExceL]

با عرض شرمندگی
این برنامه ای که شما زحمت کشیدید فقط ستون a رو با بقیه ستون ها مقایسه میکنه و تموم میشه درحالی که درخواست من اینکه که بعد از اینکه ستونa با کل ستون ها مقایسه شد از چرخه خارج بشه بعدش بیاد ستونb رو با کل ستون ها مقایسه کنه و ستون b از چزخه خارج بشه و به این صورت تا ستون آخر بره

بنده کد فوق رو بر اساس فایلی که در پست شماره سه قرار دادید و طبق خواسته ای که در شیت دوم مشخص کرده بودید نوشتم. و دقیقا همون نتیجه رو داره میده.
لذا فایل کاملتری رو قرار بدید و تا جایی که میشه نتیجه رو در یک شیت بصوررت دستی وارد کنید، اگر در توان بنده باشد مجددا برای شما انجام خواهم داد.
یا حق.

[elman1368]

با سلام مجدد بنده یه فایل دیگه گذاشتم
فدات

[M_ExceL]

با سلام مجدد بنده یه فایل دیگه گذاشتم
فدات

داخل شیت سه ، رو باتن 1 کلیک کرده و چک کنید :

Sub M_E()

Dim lr, lr2, lr3, lr4, lcol As Long

Dim c, ra, r, i, n, ss As Long

    With Application
    
        .ScreenUpdating = False
        
        .EnableEvents = False
        
            Sheets(3).Cells.ClearContents
            
            Sheets(3).Cells.EntireRow.Interior.ColorIndex = 0
            
            clr = 13
            
            lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row
            
            lcol = Sheets(1).Cells(1, Columns.Count).End(1).Column
            
                For ss = 1 To lcol
                
                    For c = 2 To lcol
                    clr = clr + 1
                        For ra = 2 To lr
                        
                        lr2 = Sheets(1).Cells(Rows.Count, c).End(3).Row
                        
                            For r = 2 To lr2
                            
                                If Sheets(1).Cells(ra, ss).Column = Sheets(1).Cells(r, c).Column Then
                                
                                    c = c + 1
                                    
                                ElseIf Sheets(1).Cells(ra, ss).Column > Sheets(1).Cells(r, c).Column Then
                                
                                    c = Sheets(1).Cells(ra, ss).Column + 1
                                    
                                End If
                                
                                If Sheets(1).Cells(ra, ss).Text = Sheets(1).Cells(r, c).Text Then
                                    Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0).EntireRow.Interior.ColorIndex = clr
                                    'Range().EntireRow.Interior.ColorIndex
                                    
                                    Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0) = Chr(211) & Chr(202) & _
                                    Chr(230) & Chr(228) & " " & Mid(Sheets(1).Cells(r, c).EntireColumn.Address, 2, 1) & " , " & _
                                    Mid(Sheets(1).Cells(ra, ss).EntireColumn.Address, 2, 1)
                                    Sheets(3).Cells(Rows.Count, 2).End(3).Offset(1, 0) = Sheets(1).Cells(r, c)
                                
                                End If
                                
                                If clr = 16 Then clr = 13
                                
                            Next r
                            
                        Next ra
                        
                    Next c
                
                Next ss
                
                
                lr3 = Sheets(3).Cells(Rows.Count, 1).End(3).Row
                
                For i = 2 To lr3
                
                    For c = 1 To lcol
                    
                        lr4 = Sheets(1).Cells(Rows.Count, c).End(3).Row
                        
                            For n = 2 To lr4
                            
                                If Sheets(3).Cells(i, 2) = Sheets(1).Cells(n, c) Then
                                
                                     Sheets(3).Cells(i, Columns.Count).End(1).Offset(, 1) = Chr(211) & Chr(202) & Chr(230) & Chr(228) & " " & _
                                     Mid(Sheets(1).Cells(n, c).EntireColumn.Address, 2, 1)
                            
                            End If
                        
                        Next n
                        
                    Next c
                    
                Next i
        
        .EnableEvents = True
        
        .ScreenUpdating = True
        
    End With

End Sub

[elman1368]

سلام دوست عزیز بازم نشد
الان تو اون فایل تا ستون i هستش اگه من بیام چند تا ستون دیگه به ستون هام اضافه کنم تو مقایسه فقط تا i مقایسه میشه و سه تای دیگه مقایسه نمیشه
من میخوام با تغییر تعداد ستون ها برنامه همه رو با هم مقایسه بکنه

[M_ExceL]

سلام دوست عزیز بازم نشد
الان تو اون فایل تا ستون i هستش اگه من بیام چند تا ستون دیگه به ستون هام اضافه کنم تو مقایسه فقط تا i مقایسه میشه و سه تای دیگه مقایسه نمیشه
من میخوام با تغییر تعداد ستون ها برنامه همه رو با هم مقایسه بکنه

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

lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row          
lcol = Sheets(1).Cells(1, Columns.Count).End(1).Column

دو خط فوق نشون میده که تا اخرین ردیف و ستون باید بررسی بشه.
مقدار lcol تعداد ستون ها رو از ردیف اول شیت 1 میگیره، احتمالا شما ستون هایی که اضافه می فرمایید ردیف اول رو خالی قرار می دید،
شما فایلی که ستون های جدید رو اضافه کردید و اینکه می فرمایید " فقط تا i مقایسه میشه" رو پیوست بفرمایید تا یک بار دیگر بررسی کنیم.
یا حق.

[elman1368]

سلام دوست عزیز واسه ذخیره کردن این ارور رو میده فکر کنم دلیل این مشکل این باشه