ترحيل بيانات من قائمة لأخرى

[abdurhman_edan]

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

أسعد الله أيامكم ولياليكم بالخير

أود من أصحاب العلم والمعرفة.. التوضيح ... حسب الصورة المرفقة.. ولكم جزيل الشكر والامتنان

ASA1.zip

تم تعديل يونيو 30, 2017 بواسطه abdurhman_edan

[ابراهيم الحداد]

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

انسخ هذا الكود والصقه فى موديول وخصص له زر

Sub TransDataArray()

Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Arr = Sheet1.Range("C2:E" & Sheet1.Range("D" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 3) = "متزوج" Then
p = p + 1
For j = 1 To UBound(Arr, 2)
Temp(p, j) = Arr(i, j)
Next
End If
If Arr(i, 3) = "اعزب" Then
q = q + 1
For j = 1 To UBound(Arr, 2)
Temp(q, j) = Arr(i, j)
Next
End If
Next

Sheet1.Range("G2").Resize(p, UBound(Temp, 2)).Value = Temp
Sheet1.Range("K2").Resize(q, UBound(Temp, 2)).Value = Temp

End Sub

 

[abdurhman_edan]

بارك الله فيك.. وشكرا لرد السريع...

ولكن النتيجة كالتالي.....

 

 

[ابراهيم الحداد]

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

احفظ الملف بصيغة 2003  او اعلى حتى يتم تنفيذ الكود او قم بارسال الملف نفسه

ويجب ان تتأكد ايضا من رقم الشيت فى الملف الاصلى يتوافق مع رقم الشيت كما فى الكود

عموما يوجد خطأ فى الكود السابق وقد تم اصلاحه لذا يرجى استبداله بهذا الكود

Sub TransDataArray()
Dim Arr As Variant, Temp As Variant, Temp2 As Variant
Dim i As Long, j As Long, p As Long
Arr = Sheet1.Range("C2:E" & Sheet1.Range("D" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 3) = "متزوج" Then
p = p + 1
For j = 1 To UBound(Arr, 2)
Temp(p, j) = Arr(i, j)
Next
End If
Next
Sheet1.Range("G2").Resize(p, UBound(Temp, 2)).Value = Temp
For ii = 1 To UBound(Arr, 1)

If Arr(ii, 3) = "اعزب" Then
q = q + 1
For j = 1 To UBound(Arr, 2)
Temp(q, j) = Arr(ii, j)
Next
End If
Next

Sheet1.Range("K2").Resize(q, UBound(Temp, 2)).Value = Temp

End Sub

 

تم تعديل يونيو 30, 2017 بواسطه زيزو العجوز

[abdurhman_edan]

حبيبنا.. زيزو ..

ما ضبط معي.. لو تكرمت... أرفقت لك الملف.. عدله وأرفقه..

شكرا لتعاونك

ASA1--2003.zip

[ياسر خليل أبو البراء]

بارك الله فيك أخي العزيز زيزو وجزيت خيراً على مساعداتك القيمة في كافة الموضوعات

أخي الكريم عبد الرحمن المشكلة لديك في اسم ورقة العمل البرمجي .. في ملفك الأخير ليست باسم Sheet1 وإنما باسم ورقة1

جرب الملف المرفق التالي فيه كود الأخ زيزو

 

ASA1--2003.rar

[ابراهيم الحداد]

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

تفضل

 

ASA1--2003.rar

[abdurhman_edan]

أشكر لكم تعاونكم الكريم

وأشكر كل من ساهم في استمرارية هذه المدرسة النموذجية

النتيجة موفقة.. بإذن الله تعالى