مطلوب كود ترحيل على اساس شرط رقم الحساب

[Tarazan]

الاساتذة الافاضل ومشرفو هذا الموقع الرائع اصحاب الخبرة والخبراء في اكسل

يرجى المساعدة بكتابة كود ترحيل للملف المرفق ومن ثم اعادة نفس الملف

ملاحظة المطلوب موجود داخل المرفق

كود لترحيل حذيفة.rar

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

أخي الكريم طرزان

الملف عامل زي الخريطة ..حاسس إني تهت في التضاريس الموجودة ..نمسك نقطة نقطة عشان أنا بصراحة تهت ..أول خطوة قلت عايز تنسخ النطاق من أول الخلية q3 لحد آخر الصف تمام أوي .. مقلتش الصف اللي هيتنسخ ده هيروح فين في خريطة الباب الثاني

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

تقبل تحياتي

 

[Tarazan]

اعتذر ع التأخير

اول خطوة نريد نسه السطر بصفحة البيان

ولصقه بآخر سطر بدفتر اليومية (صفحة الباب الثاني)

الخطوة الثالثة و الاخيرة هي الترحيل حسب الشرط

عندنا لكل حساب جدول ونسميه سجل خاص فيه 

حيث الشرط (حسب رقم الحساب الموجود بالعمود الاول بدفتر اليومية) و ترحيل البيانات الملونة باللون الازرق ترحيلها لحساباتها

للمتابعة ان اردت ياسر خليل ابو البراء

ع الفيس huzaifa syrian

[الـعيدروس]

السلام عليكم

جرب الكود التالي

مثل ماتفضل اخي الحبيب ياسر خليل

ملفك ملخبط شويات

كان بالامكان عمل ورقة لكل عميل اريح لك

 

 

 

Sub Ali_copy()
Dim Sht As Worksheet, Ws As Worksheet
Dim Num, C, R, Cl, Rw
Set Sht = Sheets("الباب الثاني")
Set Ws = Sheets("بيان")
'===
Ali_Sp False
'===
Ws.Range("Q3:Aq3").Copy
Sht.Range("A" & Sht.Cells(191, 1).End(xlDown).Row + 1).PasteSpecial xlPasteValues
Sht.[A192:AA192].Copy
Sht.[A45].PasteSpecial xlPasteValues
With Sht
For C = 30 To 240
If CStr(.Cells(280, C)) Like "*" & "البند" & "*" Then
Num = Trim(Replace(Split(.Cells(280, C), "/")(1), "/", ""))
For R = 245 To .Cells(245, 1).End(xlDown).Row
  If Trim(.Cells(R, 1)) = Num Then
   Rw = .Cells(R, 1).Row: Cl = .Cells(280, C).Column - 1
   With .Cells(.Cells(.Rows.Count, Cl).End(xlUp).Row, Cl)
     .Offset(1, 0) = Sht.Cells(Rw, 1)
     .Offset(1, 1) = Sht.Cells(Rw, 2)
     .Offset(1, 2) = Sht.Cells(Rw, 3)
     .Offset(1, 4) = Sht.Cells(Rw, 5)
     .Offset(1, 5) = Sht.Cells(Rw, 6)
     .Offset(1, 6) = Sht.Cells(Rw, 7)
     .Offset(1, 7) = Sht.Cells(Rw, 8)
   End With
  End If
Next
End If
Next
End With
'===
Ali_Sp True
'===
Set Sht = Nothing
Set Ws = Nothing
End Sub
Private Function Ali_Sp(Bl As Boolean)
 With Application
   .Calculation = IIf(Bl, -4135, -4135)
   .EnableEvents = Not Bl
   .ScreenUpdating = Bl
 End With
End Function

 

[Tarazan]

شكرااخي العيدروس

لعلي افضت و توسعت بشرح المطلوب لكن لا استطيع وضع كل حساب (بند) بصفحة نظرا لطبيعة عملي ولكن لو تتبعتم الخطوات مرقمة لعرفتم المطلوب و ببساطة

بكل الاحوال اشكركم و ساجرب كودك