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

في 28‏/1‏/2023 at 11:26, alsihran said:

ليس هذا المطلوب أخي الكريم 

المطلوب عمل Pivot Tabels

واظهار الاعمدة s1   s2 s3 s4 s5 s6 s7 s8 s9 s10

وعد القيمة 2 لكل id_Ccallg  من كل من عمود 

شكرا لك 

ارسل تصور للنتائج

تم عمل تقرير Pivot Tabels

عمود id_Ccallg  اساس وشرط العد لكل الاعمده عد وليس جمع القيم

لعل هذا يكون المطلوب

المصنف1.xlsx

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

المصنف1.xlsb

اخى ضاحى

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

اخى وجيه

اكرمكم الله ونفع بكم

اخى الحبيب  ضاحى

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

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

مع ان الكنترول 1 2 3 4 الى انك اخترت فى الحلقة التكراريه من 0 1 2 3 واعلم انك اضفت واحد +1

لما لم تستخدم من 4:1 حاولت اعطتنى خطا

For AddEvent = 0 To 3

Set LblEvent(AddEvent).LblBtn = Me("Btn" & AddEvent + 1)
Next AddEvent

لا اجد فى الكود ما يخفى اسماء التبويبات رغم انها تظهر فى التصميم ولا تظهر فى التشغيل page1 page2 page3 page4

اخى ضاحى

ممتاز وبارك الله فيك

صيغ الصور بحيث لا تزيد مساحة البرنامج فى حالة وجود اكثر من فورم

وافضل برنامج لتصميم صور للفورم 

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

الاستاذ محمد

اشكرك كل الشكر فقد وصلت المعلومه

.End(Direction)
xlToLeft = 1
xlToRight = 2
xlUp = 3
xlDown = 4

وفعلا رقم 2 تعبر عن cells(2,1)

فهل هناك ارقام اخرى لتغيير الخلايا 

اشكرك اخى محمد

السلام عليكم

اريد ان اعرف وظيفة الارقام فى الكود التالى

Worksheets(WS.Name).Cells(Rows.Count, 1).End(3)(2)

هل رقم 3 بديل xlup

ورقم 2

استاذ سليم

اكوادك رائعة وفيها ابداعات

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

اخوتى الاعزاء

بعد اعادة انشاء الملف الافتراضى فى المسار C:\Users\saadabed\AppData\Local\Temp\Rar$DIa3740.16254

افتح الاكسيس مره او اكثر لاجد اختفاء ملفRar$DIa3740.16254

واضطر لانشاءه مره اخرى 

فهل هناك من حل

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

الرساله بتقول الملف غير موجود

تم انشاء ملف جديد بالاسم والحمد لله

اشكركم

السلام عليكم

تظهر لدى رساله فى بداية تشغيل الاكسيس مكونه من سطرين

تعذر على ميكرسوفت اكسيس تغيير دليل العمل الى مسار temp

تاكد من انك تستخدم محرك الاقراص الصحيح وان طول المسار هو 260 حرف او اقل

عملت رفع للاوفيس 2016 وتم عمل ستب ولا فائده 

علما لو وافقت على الرساله يعمل البرنامج كل الملفات اى كان موقعها على الجهاز

استاذ سليم

كل الشكر والتقدير وصلت المعلومه 

واكتملت الفكره

اشكرك

اشكرك

استاذى الفاضل سليم

اسال الله ان يجزيك خيرا على الابداعات التى تقدمها

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

ما افهمه من الكود الاعلان عن المتغيرات

Dim Rg_A As Range
Dim Rg_D As Range, Rg_G As Range
Dim a%, d%, g%, X%
Dim St1$, St2$
Dim Dic As Object

ثم مسح مكان استدعاء البيانات

Range("k3").CurrentRegion.ClearContents

ثم تعيين المتغيرات وتعريفها

Set Rg_A = Range("A3", Range("A2").End(4))
Set Rg_D = Range("D3", Range("D2").End(4))
Set Rg_G = Range("G3", Range("G2").End(4))
a = Rg_A.Rows.Count: d = Rg_D.Rows.Count
g = Rg_G.Rows.Count
St1 = "All Products": St2 = "All Volume"
Set Dic = CreateObject("Scripting.dictionary")

ثم عمل ثلاث حلقات تكراريه تبدا من الصف الثالث الى عدد صفوف الرنج المشار اليه بالحلقه 

For X = 3 To a - 2
 If Not Dic.exists(Cells(X, 1).Value) Then
   Dic(Cells(X, 1).Value) = Cells(X, 2)
 Else
   Dic(Cells(X, 1).Value) = Dic(Cells(X, 1).Value) + Cells(X, 2)
 End If
 Next

ما افهمه من الحلقه التكراريه اذا لم تجد عنصر الكائن اى عدم تكراره فى الرنج فانه يساوى cells(x,2 والا اللى انا فهمه اجمع العنصر بالرقم المجاور

ارجو شرح هذه الجزئية

اشكرك

الباقى واضح