أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


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





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

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



21-07-2020 11:03 صباحا
هانى على
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 474
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 5
يتابعونه : 4
قوة السمعة : 855
عدد الإجابات: 8
 offline 

السلام عليكم اساتذتى  الكرام ... أرجو مساعدتى
لو امكن اضافة هذا الصف الأصفر تلقائيا من داخل الكود
اكن لكم من الشاكرين .. فأريد اضافة هذا الصف بعد الترحيل الى الصفحة المعنية
ولكن بعد يوم 15 من كل شهر وكمان بعد اخر يوم من كل شهر سواء كان 28 أو 29 كما بشهر
فبراير او كباقى شهور السنة كيوم 30 أو 31 حسب الشهر
وكما ترى وذلك لعمل اجمالى العمليات التى تمت بهذه المدة
ولأن الموردين يقوموا بإحضار الفاتورة عندى مرتين بالشهر
مرة يوم 15 بحيث تضم كل العمليات التى تم تنفيذها من يوم 1 الى يوم 15 بنفس الشهر..
والمرة الأخرة اخر يوم بنفس الشهر وذلك كما بالصورة


Sub Test()
    Dim x, y, ws As Worksheet, sh As Worksheet, rng As Range, r As Long, m As Long
    Dim z As Long
    UseSpeedyCode True
        Set ws = ThisWorkbook.Worksheets("Main")
        z = ws.Cells(Rows.Count, 1).End(xlUp).Row
        For r = 3 To z
            If Evaluate("ISREF('" & ws.Cells(r, 3).Value & "'!A1)") Then
                 Set sh = ThisWorkbook.Worksheets(ws.Cells(r, 3).Value)
                 m = sh.Cells(Rows.Count, 18).End(xlUp).Row + 1
                 c = WorksheetFunction.CountIfs(sh.Range("a3:a" & m), _
                 ws.Cells(r, 1), sh.Range("r3:r" & m), ws.Cells(r, 2))
                 If c > 0 Then GoTo 1
                 sh.Cells(m, 1).Value = ws.Cells(r, 1).Value
                 sh.Cells(m, 18).Value = ws.Cells(r, 2).Value
                 sh.Cells(m, 19).Value = WorksheetFunction.SumIfs( _
                      ws.Range("g3:g" & z), ws.Range("a3:a" & z) _
                      , sh.Cells(m, 1).Value, ws.Range("b3:b" & z), _
                      sh.Cells(m, 18).Value, ws.Range("c3:c" & z), sh.Name)
                 sh.Cells(m, 20).Value = WorksheetFunction.SumIfs( _
                      ws.Range("h3:h" & z), ws.Range("a3:a" & z) _
                      , sh.Cells(m, 1).Value, ws.Range("b3:b" & z), _
                      sh.Cells(m, 18).Value, ws.Range("c3:c" & z), sh.Name)
                For x = 3 To 15 Step 4
                    For y = x - 1 To x + 2
                        sh.Cells(m, y).Value = WorksheetFunction.SumIfs( _
                             ws.Range("d3:d" & z), ws.Range("a3:a" & z), _
                             sh.Cells(m, 1).Value, ws.Range("b3:b" & z), _
                             sh.Cells(m, 18).Value, ws.Range("c3:c" & z), _
                             sh.Name, ws.Range("e3:e" & z), sh.Cells(1, x).Value, _
                             ws.Range("f3:f" & z), sh.Cells(2, y).Value)
                    Next
                Next
            End If
1
        Next r
    UseSpeedyCode False
      MsgBox "Done...", 64
End Sub
Public Function UseSpeedyCode(goFast As Boolean)
    Dim calc As Long
    With Application
        .ScreenUpdating = Not goFast
        .EnableEvents = Not goFast
        If goFast Then
            calc = .Calculation
                 .Calculation = xlCalculationManual
        Else
            .Calculation = calc
        End If
    End With
End Function
Sub Nor()
For x = 3 To 15 Step 4
For z = x - 1 To x + 2
MsgBox Cells(1, x)
MsgBox Cells(2, z)
Next
Next
End Sub


لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
uYSA0_6.16c108109446097fc3469c265763adeb
 
 
  TransportatioCompanies.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(266.367) KB


23-07-2020 11:13 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مساعدة فى اضافة صف اصفر للإجمالى بعد الترحيل
جرب هذا الكود

Option Explicit
Sub INsert_rows()
Dim i%, k%, m%
Application.ScreenUpdating = False
m = Cells(Rows.Count, 1).End(3).Row + 1
For i = m To 3 Step -1
 If Not IsDate(Cells(i, 1)) Then
 Cells(i, 1).EntireRow.Delete
 End If
 Next
For i = 3 To Range("a3", Range("a2").End(4)).Rows.Count
 m = Day(Cells(i, 1))
 If m > 15 Then Exit For
 If m = 15 Then
 k = i
 End If
 Next
 If k Then
  Cells(k + 1, 1).Insert
  Cells(k + 1, 1) = "TOTAL"
  Cells(k + 1, 2).Resize(, 24).Formula = _
        "=SUM(B3:B" & k & ")"
  Cells(k + 1, 2).Resize(, 24).Value = _
  Cells(k + 1, 2).Resize(, 24).Value
 End If
 m = Cells(Rows.Count, 1).End(3).Row + 1
  Cells(m, 1) = "TOTAL"
  Cells(m, 2).Resize(, 24).Formula = _
      "=SUM(B" & k + 2 & ":B" & m - 1 & ")"
  Cells(m, 2).Resize(, 24).Value = _
  Cells(m, 2).Resize(, 24).Value
  Application.ScreenUpdating = True
End Sub


الملف مرفق
 
 
  SalimCompanies.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(210.007) KB


24-07-2020 12:18 صباحا
مشاهدة مشاركة منفردة [2]
هانى على
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 474
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 5
يتابعونه : 4
قوة السمعة : 855
عدد الإجابات: 8
 offline 
look/images/icons/i1.gif مساعدة فى اضافة صف اصفر للإجمالى بعد الترحيل
بارك الله فيك استاذ سليم وجزاك الله خير الثواب -وشكرا جزيلا لحضرتك على الرد , كود ممتاز
ولكن كما ترى حضرتك بالصور فتم ادخال صف بيوم 31/07 بصفحة Main وعند الترحيل تم ترحيل هذا الصف الى الصفحة المعنية ولكن بعد تفعيل كود حضرتك وكما ترى اصبح صف يوم 31/07/2020 فارغاً بلا اعداد او أسعار
كما ان الكود يقوم بإضافة صف Total فى الصفحة النشطة فقط بمعنى لو كانت صفحة Main هى الصفحة المفتوحة والنشطة فيقوم الكود بأضافة صف المجموع بها وطبعا كما تعلم هذا غير مرغوب فيه لأنى اريد اضافة هذا الصف الى الصفحة المرحل اليها وليس صفحة ادخال البيانات والمرحل منها وهى Main
وياريت لو فى استطاعة حضرتك ان يتم تفعيل كود حضرتك مع الكود القديم الموجود بالملف والخاص بالترحيل ,أكن لك من الشاكرين ... واسف لك جدا على الإطالة
k5AcK_1 uiuhx_2
 
 
 


24-07-2020 08:12 صباحا
مشاهدة مشاركة منفردة [3]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مساعدة فى اضافة صف اصفر للإجمالى بعد الترحيل
جرب هذا الملف الثاني (نموذج فقط يمكنك التعديل بعدد الاعمدة)
بطيء بعض الشيء ولا اعرف السبب مع ان حجمه 140 كيلو

Option Explicit

Sub Get_all_sum()
If ActiveSheet.Name <> "Total Travel" Then GoTo Bay_Bay
 Dim Ro%, i%, t%, m%
 Dim myDate As Date
 Ro = Cells(Rows.Count, 1).End(3).Row
 Application.ScreenUpdating = False
 For i = Ro To 3 Step -1
   If Not IsDate(Range("A" & i)) Then
    Rows(i).Delete
    End If
 Next
 Ro = Cells(Rows.Count, 1).End(3).Row
 For i = Ro To 3 Step -1
     myDate = Cells(i, 1)
    If myDate = DateSerial(Year(myDate), Month(myDate) + 1, 0) _
       Or Day(myDate) = 15 Then
       Cells(i + 1, 1).EntireRow.Insert
       Cells(i + 1, 1) = "TOTAL"
       Cells(i + 1, 1).Resize(, 5).Interior.ColorIndex = 6
    End If
 Next

 t = 3
 Ro = Cells(Rows.Count, 1).End(3).Row
 For i = 3 To Ro
  If Cells(i, 1) = "TOTAL" Then
   m = Cells(i, 1).Row - 1
   Cells(i, 2).Resize(, 4).Formula = "=SUM(B" & t & ":B" & m & ")"
  t = m + 2
  End If
 Next
 Range("A3:E" & Ro).Value = Range("A3:E" & Ro).Value
Bay_Bay:
  Application.ScreenUpdating = True
End Sub


الملف مرفق
 
 
  SalimCompanies_1.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(141.134) KB


24-07-2020 12:55 مساء
مشاهدة مشاركة منفردة [4]
هانى على
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 474
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 5
يتابعونه : 4
قوة السمعة : 855
عدد الإجابات: 8
 offline 
look/images/icons/i1.gif مساعدة فى اضافة صف اصفر للإجمالى بعد الترحيل
بارك الله فيك استاذ سليم كود ممتاز ولكن بالفعل كما اخبرتنى ثقيل جداً ولا أعرف ما هو السبب فى ذلك
ولكن لا يمكن استخدامه معى لأنى امتلك عدة شركات نقل اتعامل معها وليس هذه الصفحة فقط  Total Travel
المحصورة داخل الكود ... ولكن لدى ايضا حوالى 5 صفحات أخرى لأسماء شركات النقل مثل Limousin Agent , Aqua Park Travel

فطلبى لو هناك كود يمكن اضافته الى كود الترحيل الأصلى ليكون مرن فى تنفيذ هذا الطلب وهو اضافة صف الإجمالى مرة فى منتصف الشهر والأخر فى نهاية الشهر كما اخبرتكم سابقاً
ولكم منى جزيل الشكر

03-08-2020 10:13 صباحا
مشاهدة مشاركة منفردة [5]
هانى على
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 474
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 5
يتابعونه : 4
قوة السمعة : 855
عدد الإجابات: 8
 offline 
look/images/icons/i1.gif مساعدة فى اضافة صف اصفر للإجمالى بعد الترحيل
السلام عليكم استاذ سليم ...أعتذر وأتأسف جداً من حضرتك ولكن الملف لم يكن فارغاً
على العموم تم ادخال بيانات أكثر بالملف كما تريد -تفضل حضرتك

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  TransportatioCompanies.xlsm   تحميل xlsm مرات التحميل :(1)
الحجم :(543.631) KB


03-08-2020 12:05 مساء
مشاهدة مشاركة منفردة [6]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مساعدة فى اضافة صف اصفر للإجمالى بعد الترحيل
لا أفهم كيف  تريد نقل بيانات من صفحة الى اخرى
الصفحة  Main  تحتوي على 8 أعمدة  A من  H الى
والصفحات الباقية تحتوي على 26 عامود   من  A الى Y
و ذا كان الأمر كذلك اي أعمدة تريد نقلها
 الخلايا المدمجة يحب ازالتها كما في     D &E,  H &I     الخ....

Itm4c_Pic_2
 
 





الكلمات الدلالية
الترحيل ، اصفر ، للإجمالى ، مساعدة ، اضافة ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:51 صباحا