جلب البيانات بكود وليس معادلة

[وليد المصرى 1]

السلام عليكم ورحمة الله وبركاتة

ارجو المساعدة من الاخوة الافاضل اريد جلب بيانات من شيت الى شيت اخر ولكن بكود وليس بمعادلة

الباسورد 1

اشكركم جميعا

مهم.rar

[عبدالله المجرب]

السلام عليكم

ضع هذا الكود في حدث الورقة PART 1

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

Set MyRng = Sheets("1").[B6:I4090]

If Not Intersect(Target, [H2,H22,H42]) Is Nothing Then

Cells(Target.Row + 5, 5) = Application.VLookup(Target, MyRng, 3, 0)

Cells(Target.Row + 7, 5) = Application.VLookup(Target, MyRng, 4, 0)

Cells(Target.Row + 9, 5) = Application.VLookup(Target, MyRng, 8, 0)

Cells(Target.Row + 11, 5) = Application.VLookup(Target, MyRng, 6, 0)

End If

End Sub

[طارق محمود]

السلام عليكم

أخي العزيز

ضع الكود التالي في حدث الورقة (PART 1)

Private Sub Worksheet_Change(ByVal Target As Range)


Dim x As String, v As Variant, r, j, T_R As Integer, myRange As Range

x = Target.Address

If x <> "$H$2" And x <> "$H$22" And x <> "$H$42" Then Exit Sub

v = Target.Value

T_R = Target.Row

On Error Resume Next


With Sheets("1")

	Set myRange = .Range("B8:B" & .[B10000].End(xlUp


Private Sub Worksheet_Change(ByVal Target As Range)


Dim x As String, v As Variant, r, j, T_R As Integer, myRange As Range

x = Target.Address

If x <> "$H$2" And x <> "$H$22" And x <> "$H$42" Then Exit Sub

v = Target.Value

T_R = Target.Row

On Error Resume Next


With Sheets("1")

	Set myRange = .Range("B8:B" & .[B10000].End(xlUp).Row)

End With


r = WorksheetFunction.Match(v, myRange, 0)

If r < 1 Then

	For j = 5 To 11 Step 2

	 Range("E" & j + T_R & ":G" & j + T_R).ClearContents

	Next j

	 Range("E" & 5 + T_R & ":G" & 11 + T_R).Interior.ColorIndex = 3

	MsgBox ("لايوجد هذا الرقم الوظيفى في الورقة 1")

	 Range("E" & 5 + T_R & ":G" & 11 + T_R).Interior.ColorIndex = xlNone

	Exit Sub


Else

	Cells(5 + T_R, "E") = Sheets("1").Cells(7 + r, 4)

	Cells(7 + T_R, "E") = Sheets("1").Cells(7 + r, 5)

	Cells(9 + T_R, "E") = Sheets("1").Cells(7 + r, 9)

	Cells(11 + T_R, "E") = Sheets("1").Cells(7 + r, 7)

End If


End Sub

أو تفضل المرفق

مهم2.rar

[طارق محمود]

السلام عليكم

أخي / أبا أحمد

إيه الأكواد الشديدة والمختصرة دي

ماشاء الله

ربنا يزيدك

[عبدالله المجرب]

شكراً لك استاذ طارق على الدعم والمساندة وهذا من فضل الله ثم ما تعلمناه منكم

[بن علية حاجي]

السلام عليكم ورحمة الله

بارك الله فيكما اخوايا الكريمين أبو أحمد وطارق وجزاكما الله خير الجزاء وبارك علمكما وزادكما من نعمه... هذه المرة أخي الحبيب أبو أحمد لا أتبعك الحل بالمعادلات لأن أخانا goodlife اشترط أن لا يكون الحل بالمعادلات...

أخوك بن علية

[وليد المصرى 1]

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

اية الروعة دية يا استاذ طارق والاستاذ الفاضل ابو احمد بجد كود جميل جدا جزاكم الله خير فى الدنيا وفى الاخرة

[أبو ردينة]

ماشاء الله لا قوة إلا بالله

الأساتذة عبد الله و طارق

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

لي أستفسار بخصوص الأكواد عامة في أوراق الأكسيل

لنفرض أني قمت بإضافة زر أمر إلى ورقة العمل من خلال المطور في أوفيس 2010

هل يمكن تسجيل ماكرو بالمطلوب ثم نسخ محتوى الماكرو إلى مكان الكود المفروض كتابته لهذا الزر - و هل هناك عيوب لهذة الطريقة ؟

علما بأني من محبي تعلم كتابة الأكواد و لا أقصد بسؤالي سوى حل مؤقت لحين التمكن من كتابة كود كامل بأخطاء بسيطة أو بلا أخطاء إن شاء الله

بارك الله فيكم

تم تعديل مارس 12, 2012 بواسطه أبو ردينة