saad abed

السلام عليكم ورحمه الله وبركاته جزاك الله كل خير استاذ ضاحي

السلام عليكم ورحمه الله وبركاته احسنت وجزاك الله عنا خير الجزاء استمر والله اعمال رائعه

اخى ضاحى احسنت وجزاك الله خيرا وصلت الفكره والله مفيده جدا

السلام عليكم يفضل اضافة سطر لمسح الداتا Sht6.Range("A3:Q100000").ClearContents

اخى اكتب انت اسم الورقة Private Sub CreateSheet() Dim ws As Worksheet ss = InputBox("name is ........") Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) ws.Name = ss End Sub

جرب الاتى 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

اخى هذا الشرط يمنع مسح المجال لانه ينهى عمل الكود اذا تحقق الشرط If (sheet1.Cells(R, "b") = "") Then ' Exit Sub ' End If جرب اوقف عمل الاسطر وجرب سترى ان كل شئ على ما يرام

فهمت ما تريد استخدمت مقسم العرض يعمل من اوفيس اعلى من 2010 اختار من مقسم العرض لعمود اكس تنشن انسخ الرقم فى خليه h8 datea.xlsx

اخى الكريم غير اكواد التفريغ خارج الحلقه المتكرره 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

لعل هذا يكون المطلوب ضع اى اضافة ما دامت ممكنه سيتم التعديل datea.xlsx

ارسل تصور للنتائج تم عمل تقرير Pivot Tabels عمود id_Ccallg اساس وشرط العد لكل الاعمده عد وليس جمع القيم

لعل هذا يكون المطلوب المصنف1.xlsx

السلام عليكم ورحمة الله وبركاته الفورم به استدعاء للصوره من اى مسار فهل يمكن تغيير المسار وحفظ الصورة فى مسار اخر المصنف1.xlsb

اخى ضاحى احسنت بارك الله فيكم

اخى وجيه اكرمكم الله ونفع بكم