قرار دادن سلول های مشابه در کنار هم

[saman501]

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

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[saman501]

این هم نمونه فایل من

[saman501]

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

[Amir Ghasemiyan]

سلام دوست عزیز
اگر درست متوجه منظورتون شده باشم این کد کمکتون میکنه:

Sub exceliran()
For Each c In Sheet2.Range("A1:A16")
    For Each v In Sheet3.Range("A1:A32")
        If c = v Then
            LastRow = Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row + 1
            If LastRow = 2 And Sheet5.Cells(1, 1) = "" Then LastRow = 1
            Sheet5.Range("A" & LastRow) = c
            Sheet5.Range("B" & LastRow) = c.Offset(0, 1)
            Sheet5.Range("C" & LastRow) = c.Offset(0, 2)
            Sheet5.Range("A" & LastRow + 1) = v
            Sheet5.Range("B" & LastRow + 1) = v.Offset(0, 1)
            Sheet5.Range("C" & LastRow + 1) = v.Offset(0, 2)
        End If
    Next v
Next c
End Sub

[iranweld]

با سلام

فایل پیوست را بررسی بفرمایید

Sub asd()

Z1 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
Z2 = Sheet3.Cells(Sheet3.Rows.Count, "A").End(xlUp).Row
K = 1

For I = 1 To Z1

For J = 1 To Z2

If Sheet2.Range("A" & I) = Sheet3.Range("A" & J) Then

Range("A" & K) = Sheet2.Range("A" & I)
Range("B" & K) = Sheet2.Range("B" & I)
Range("C" & K) = Sheet2.Range("C" & I)

K = K + 1
Range("A" & K) = Sheet3.Range("A" & J)
Range("B" & K) = Sheet3.Range("B" & J)
Range("C" & K) = Sheet3.Range("C" & J)

K = K + 1

End If

Next
Next
End Sub 

[navid136220]

با سلام و خسته نباشید

با تشکر از آقای قاسمیان و کاربر حرفه ای iranweld، ترکیبی از کدهای این دو عزیز که هم سبب کلی مشمول شدن کدها و هم خلاصه شدنشان می شود را paste میکنم و امتحان نیز کردم دقیقا همان چیزی است که شما می خواهید.

Sub exceliran()
lastsheet2 = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row 'پيدا کردن رديف آخرين خانه ي پر از ستون اول شيت 2
lastsheet3 = Sheet3.Cells(Sheet3.Rows.Count, 1).End(xlUp).Row ' پيدا کردن رديف آخرين خانه ي پر از ستون اول شيت 3
For Each c In Sheet2.Range("A1:A" & lastsheet2)
For Each v In Sheet3.Range("A1:A" & lastsheet3)
If c = v Then
LastRow = Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row + 1
If LastRow = 2 And Sheet5.Cells(1, 1) = "" Then LastRow = 1
Sheet5.Range("A" & LastRow) = c
Sheet5.Range("B" & LastRow) = c.Offset(0, 1)
Sheet5.Range("C" & LastRow) = c.Offset(0, 2)
Sheet5.Range("A" & LastRow + 1) = v
Sheet5.Range("B" & LastRow + 1) = v.Offset(0, 1)
Sheet5.Range("C" & LastRow + 1) = v.Offset(0, 2)
End If
Next v
Next c
End Sub


با تشکر مجدد از اساتید محترم

[navid136220]

Sub exceliran()
lastsheet2 = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row 'پيدا کردن رديف آخرين خانه ي پر از ستون اول شيت 2
lastsheet3 = Sheet3.Cells(Sheet3.Rows.Count, 1).End(xlUp).Row ' پيدا کردن رديف آخرين خانه ي پر از ستون اول شيت 3
For Each c In Sheet2.Range("A1:A" & lastsheet2)
For Each v In Sheet3.Range("A1:A" & lastsheet3)
If c = v Then
LastRow = Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row + 1
If LastRow = 2 And Sheet5.Cells(1, 1) = "" Then LastRow = 1
Sheet5.Range("A" & LastRow) = c
Sheet5.Range("B" & LastRow) = c.Offset(0, 1)
Sheet5.Range("C" & LastRow) = c.Offset(0, 2)
Sheet5.Range("A" & LastRow + 1) = v
Sheet5.Range("B" & LastRow + 1) = v.Offset(0, 1)
Sheet5.Range("C" & LastRow + 1) = v.Offset(0, 2)
End If
Next v
Next c
End Sub

[saman501]

سلام ممنون که کمک کردین اما یک مشکل پیش اومده برنامه ای که اقای نوید نوشتن 50 تا فایل تبدیل میکنه به 1150 و برنامه اقای iranweld هم تو تعداد بالا هنگ میکنه یا خیلی طول میکشه

[iranweld]

با سلام



با اضافه شدن کد ذیل به ابتدا و انتهای ماکرو ،از آپدیت شدن صفحه نمایش در حین پروسه جلوگیری شده و به نسبت سرعت بالاتر میرود

sub test
Application.ScreenUpdating = False




کدهای برنامه



Application.DisplayAlerts = true 

[mostafa227]

با سلام. می خواهم ستون a را با ستون e مقایسه کند و سپس اطلاعات ستون f را در ستون c قرار بدهد.area.xlsx