هل لي بكود مقارنه على عمودين

[الـعيدروس]

السلام عليكم

الاخوة الافاضل

كثرة طلباتي وارجو ان تتسع صدوركم

اريد كود مقارنة بين عمود ورقة1 وعمود في ورقة2

شرح مختصر والمطلوب موضح بالتفصيل على المرفق

والسلام عليكم

كود مقارنه.rar

[طارق محمود]

السلام عليكم

أخي الكريم

جرب هذا الكود

Sub compare_Sh1_2()

Dim Acc(999) As Variant, LstR As Range

Sheets(1).Activate

lastRw1 = [B10000].End(xlUp).Row


' Save Existing Accounts in sheet1

For x = 3 To lastRw1

	i = i + 1

	Acc(i) = Range("B" & x).Value

Next x


' Compare Existing Accounts with sheet2


lastRw2 = Sheets(2).[B10000].End(xlUp).Row


For j = 3 To lastRw2

	For x = 1 To i

    	If Acc(x) = Sheets(2).Range("B" & j) Then GoTo 10

	Next x

	Set LstR = Sheets(1).[B10000].End(xlUp).Offset(1, 0)

	Sheets(2).Range("B" & j & ":E" & j).Copy

	LstR.PasteSpecial Paste:=xlPasteValues

	LstR.Offset(0, -1) = LstR.Offset(-1, -1) + 1

10

Next j


End Sub

[الـعيدروس]

السلام عليكم

الاستاذ طارق محمود كفيت ووفيت

اكوادك كلها جميله ومختصره ماشاء الله

الله يوفقك

جربت الكود شغال 100%

جزاك الله كل خير

[طارق محمود]

ولكني لم أنتبه لموضوع الـ ص / م

اعتقد انك تستطيع إستكماله

[ياسر الحافظ]

استاذ طارق

تسلم ايدك

كما قال اخونا العيدروس اكوادك مختصرة وواضحة

وفقك الله

ابو الحارث

[الـعيدروس]

السلام عليكم

الاستاذ طارق محمود حفظك الله ورعاك

ارجو من سيادتكم اكمال الفكره

وهو (ص) و (م)

توضح

بمعنى الموجود في ورقة2 وغير موجود في ورقة 1

يجلبه لورقة 1 والذي موجود في ورقة2 وموجود في ورقة 1

يطبع في عمود (E) ورقة1 "غ"

صـراحه النقطه هذي قفلت مخي من الصباح وانا احوس عليها

ولم اوصل الى حل

الله يوفقك والعذر منك والسموحه على كثرة الطلبات

والسلام عليكم

هذا الكود

Sub gedwal_g()

'==================================================

'==================================================

Dim Acc(999) As Variant, LstR As Range

Sheets("ص").Activate

lastRw1 = [B10000].End(xlUp).Row

For x = 3 To lastRw1

    	i = i + 1

    	Acc(i) = Range("B" & x).Value

Next x

lastRw2 = [i10000].End(xlUp).Row

For j = 3 To lastRw2

    	For x = 1 To i

    	If Acc(x) = Range("i" & j) Then GoTo 10

    	Next x

    	Set LstR = Sheets("ص").[B10000].End(xlUp).Offset(1, 0)

    	Sheets("ص").Range("h" & j & ":k" & j).Copy

    	LstR.PasteSpecial Paste:=xlPasteValues

    	LstR.Offset(0, -1) = LstR.Offset(-1, -1) + 1

10

Application.CutCopyMode = False

Next j

x = Range("B3").End(xlDown).Row

For l = 3 To x

If Application.WorksheetFunction.CountIf(Sheets("ص").[i3:i512], Cells(l, 2)) > 0 Then

Cells(l, 2).Offset(0, 3) = "r"

End If

Next l

'==================================================

' عمل التنسيق من خليه

'==================================================

i = Range("d15000").End(xlUp).Row

Range("o1").Copy

Range("a" & i & ":c" & i).Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

Range("ddd").Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

Application.CutCopyMode = False

[a1].Select

e = Range("b15000").End(xlUp).Row

Range("q1").Copy

Range("d" & e & ":e" & e).Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

Range("fff").Offset(1, 0).PasteSpecial Paste:=xlPasteFormats

Application.CutCopyMode = False

[a1].Select

End Sub

ومرفق لكي تتضح لك الصورة بالشكل السليم

تفضل

مقارنة2.rar

[طارق محمود]

السلام عليكم

أخي العزيز

يمكنك إضافة هي السطور للكود الأول قبل نهايته

	If Sheets(2).[D2] = "م" Then

    	LstR.Offset(0, 3) = LstR.Offset(0, 2)

    	LstR.Offset(0, 2).ClearContents

	End If

ليصبح

Sub compare_Sh1_2()

Dim Acc(999) As Variant, LstR As Range

Sheets(1).Activate

lastRw1 = [B10000].End(xlUp).Row


' Save Existing Accounts in sheet1

For x = 3 To lastRw1

	i = i + 1

	Acc(i) = Range("B" & x).Value

Next x


' Compare Existing Accounts with sheet2


lastRw2 = Sheets(2).[B10000].End(xlUp).Row


For j = 3 To lastRw2

	For x = 1 To i

    	If Acc(x) = Sheets(2).Range("B" & j) Then GoTo 10

	Next x

	Set LstR = Sheets(1).[B10000].End(xlUp).Offset(1, 0)

	Sheets(2).Range("B" & j & ":E" & j).Copy

	LstR.PasteSpecial Paste:=xlPasteValues

	LstR.Offset(0, -1) = LstR.Offset(-1, -1) + 1


	If Sheets(2).[D2] = "م" Then

    	LstR.Offset(0, 3) = LstR.Offset(0, 2)

    	LstR.Offset(0, 2).ClearContents

	End If

10

Next j


End Sub

[الـعيدروس]

السلام عليكم

جزاك الله كل خير

قد توصلت الى حل ولاكن كودك مختصر جداً

الف الف شكر