تفريغ الفاتورة من البيانات بعد عملية الترحيل لأكثر من شيت

[الحسن]

اسعد الله مساءكم

أنا عندي فاتورة توزع بياناتها على عدد 2 من شيتات الاكسل لكن عندما أكتب كود تفريغ الفاتورة من البيانات لا تتم عملية ترحيل البيانات كاملة من الفاتورة إلى شيت المشتريات.

أرجو منكم المساعدة في حل هذه الإشكالية. كما أتمنى عليكم كتابة كود لإستعادة بيانات الفاتورة عند البحث عنها برقمها.

مرفق لكم الفاتورة

تقبلوا خالص الاحترام والتقدير

 

ملف فاتورة مشتريات.xlsm

[saad abed]

اخى الكريم

غير اكواد التفريغ خارج الحلقه المتكرره

Sub SaveBill()
On Error Resume Next
Dim Lrow As Integer
Lrow = ورقة3.Cells(ورقة3.Rows.Count, "a").End(xlUp).Offset(1, 0).Row
ورقة3.Cells(Lrow, "A") = ورقة1.Cells(2, "B")
ورقة3.Cells(Lrow, "B") = ورقة1.Cells(3, "B")
ورقة3.Cells(Lrow, "C") = ورقة1.Cells(4, "B")
ورقة3.Cells(Lrow, "D") = ورقة1.Cells(29, "D")
ورقة3.Cells(Lrow, "E") = ورقة1.Cells(29, "F")
ورقة3.Cells(Lrow, "F") = ورقة1.Cells(30, "F")
ورقة3.Cells(Lrow, "G") = ورقة1.Cells(31, "F")
ورقة3.Cells(Lrow, "H") = ورقة1.Cells(32, "F")
ورقة3.Cells(Lrow, "I") = ورقة1.Cells(33, "F")

Dim LastRow As Integer
Dim R As Integer

 For R = 7 To 27
  If (ورقة1.Cells(R, "b") = "") Then
  Exit Sub
  End If
  
   LastRow = ورقة2.Cells(ورقة2.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    
    ورقة2.Cells(LastRow, "A") = ورقة1.Cells(2, "B")
     ورقة2.Cells(LastRow, "B") = ورقة1.Cells(3, "B")
      ورقة2.Cells(LastRow, "C") = ورقة1.Cells(4, "B")
       ورقة2.Cells(LastRow, "D") = ورقة1.Cells(R, "B")
        ورقة2.Cells(LastRow, "E") = ورقة1.Cells(R, "C")
         ورقة2.Cells(LastRow, "F") = ورقة1.Cells(R, "D")
          ورقة2.Cells(LastRow, "G") = ورقة1.Cells(R, "E")
           ورقة2.Cells(LastRow, "H") = ورقة1.Cells(R, "F")
  
           
     Next
              
   ورقة1.Cells(2, "B") = ""
     ورقة1.Cells(3, "B") = ""
      ورقة1.Cells(4, "B") = ""
       ورقة1.Cells(R, "B") = ""
        ورقة1.Cells(R, "C") = ""
         ورقة1.Cells(R, "D") = ""
          ورقة1.Cells(R, "E") = ""
           ورقة1.Cells(R, "F") = ""
End Sub

 

[الحسن]

أشكرك أخي الكريم العضو الذهبي وجعل الله أيامك كلها دهب على تفضلك علي بالرد على الموضوع الذي طرحته.
وما أود أن أقوله بأنني قد جربت ما تفضلت به أنت قبل أن تتفضل بالاجابة وبعد إلإجابة والنتيجة أنه لم يتم بتفريغ الفاتورة من بياناتها بعد إخراج الاكواد من الحلقة التكرارية، وعند إداخال الاكواد في الحلقة التكرارية يقوم بترحيل الصف الاول من بيانات الفاتورة وجزء من الصف الثالث فقط.

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

مرة أخرى أشكرك جزيل الشكر

[saad abed]

اخى

هذا الشرط يمنع مسح المجال لانه ينهى عمل الكود اذا تحقق الشرط

 If (sheet1.Cells(R, "b") = "") Then
'            Exit Sub
'        End If

جرب اوقف عمل الاسطر وجرب سترى ان كل شئ على ما يرام

[الحسن]

عزيزي saad abed ما تفضلت به صحيح.

لكن إذا ما تم إيقاف عمل الشرط الذي اشرت إليه فسيستمر التكرار حتى ينتهي من كل الصفوف الفارغة في الفاتورة، وهذا سيشكل خلل في عمل البرنامج وتعبئة البيانات المطلوبة فقط

هل لديك تصور أخر يمكن أن يحل المشكلة؟؟؟ 

وأكون شاكراً فضلك في ذلك

[saad abed]

جرب الاتى

Sub SaveBill()
    On Error Resume Next
    Dim Lrow As Integer
    Lrow = ورقة3.Cells(ورقة3.Rows.Count, "a").End(xlUp).Offset(1, 0).Row
    ورقة3.Cells(Lrow, "A") = sheet1.Cells(2, "B")
    ورقة3.Cells(Lrow, "B") = sheet1.Cells(3, "B")
    ورقة3.Cells(Lrow, "C") = sheet1.Cells(4, "B")
    ورقة3.Cells(Lrow, "D") = sheet1.Cells(29, "D")
    ورقة3.Cells(Lrow, "E") = sheet1.Cells(29, "F")
    ورقة3.Cells(Lrow, "F") = sheet1.Cells(30, "F")
    ورقة3.Cells(Lrow, "G") = sheet1.Cells(31, "F")
    ورقة3.Cells(Lrow, "H") = sheet1.Cells(32, "F")
    ورقة3.Cells(Lrow, "I") = sheet1.Cells(33, "F")
    Dim LastRow As Integer
    Dim R As Integer
''''''''''''''''''''''''''''''''
    For R = 7 To 27
       If (sheet1.Cells(R, "b") <> "") Then
        LastRow = ورقة2.Cells(ورقة2.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
        ورقة2.Cells(LastRow, "A") = sheet1.Cells(2, "B")
        ورقة2.Cells(LastRow, "B") = sheet1.Cells(3, "B")
        ورقة2.Cells(LastRow, "C") = sheet1.Cells(4, "B")
        ورقة2.Cells(LastRow, "D") = sheet1.Cells(R, "B")
        ورقة2.Cells(LastRow, "E") = sheet1.Cells(R, "C")
        ورقة2.Cells(LastRow, "F") = sheet1.Cells(R, "D")
        ورقة2.Cells(LastRow, "G") = sheet1.Cells(R, "E")
        ورقة2.Cells(LastRow, "H") = sheet1.Cells(R, "F")
        End If
    Next
    ''''''''''''''''''''''''''''''''''''''''
       sheet1.Range("b2").ClearContents
       sheet1.Range("b3").ClearContents
       sheet1.Range("b4").ClearContents
       sheet1.Range("b7:e27").ClearContents
End Sub

غيرت اسم الورقة من ورقه1 الى sheet1

[الحسن]

أشكرك جزيل الشكر عزيزي saad abed على تعبك ومجهودك معي 

الأن الأمور تمام