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

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


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





حذف صفوف إعتمادا على شرط

السلام عليكم ورحمة الله وبركاته المرفق التالى لتصدير أوراق محددة للعديد من المصنفات المغلقة الى مصنف واحد مغلق [code]JiM ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


29-09-2020 08:44 مساء
أبو سجده
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-08-2017
رقم العضوية : 95
المشاركات : 222
الجنس : ذكر
تاريخ الميلاد : 2-2-1965
يتابعهم : 1
يتابعونه : 3
قوة السمعة : 328
 offline 

السلام عليكم ورحمة الله وبركاته
المرفق التالى لتصدير أوراق محددة للعديد من المصنفات المغلقة الى مصنف واحد مغلق
'الكود للأستاذ الفاضل ياسر خليل أبو البراء
' وتمت الإضافات بمعرفة الأستاذ الفاضل حسونه
'بارك الله فيكم جميعا
Sub Test()
    Const shName1 As String = "ورقة8", shName2 As String = "ورقة9"
    Dim wbResult As Workbook, wb As Workbook, sh1 As Worksheet, sh2 As Worksheet, ws1 As Worksheet, ws2 As Worksheet, myPath As String, myFile As String, sh As Worksheet
    Application.ScreenUpdating = False
        Set wbResult = Workbooks.Open(ThisWorkbook.Path & "\النتائج.xlsx")
        With wbResult
            Set sh1 = .Worksheets(shName1)
            Set sh2 = .Worksheets(shName2)
            sh1.Range("A1").CurrentRegion.Offset(1).Clear
            sh2.Range("A1").CurrentRegion.Offset(1).Clear
        End With
        myPath = ThisWorkbook.Path & "\المجلد الرئيسى\"
        myFile = Dir(myPath & "*.xls*")
        Do While myFile <> ""
            Set wb = Workbooks.Open(myPath & myFile, False)
            Set ws1 = wb.Worksheets(shName1)
            Set ws2 = wb.Worksheets(shName2)
            ws1.Range("A1").CurrentRegion.Offset(1).Copy sh1.Range("A" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            ws2.Range("A1").CurrentRegion.Offset(1).Copy sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
           '----------------------------------------------------------------------------------------------
            For Each sh In wbResult.Worksheets(Array("ورقة8", "ورقة9"))
            With sh
                .Range("A1:K" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).AutoFilter Field:=4
                With .AutoFilter.Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=Range("d2:d" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1), SortOn:=xlSortOnValues, Order:=xlAscending
                    .SortFields.Add Key:=Range("f2:f" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1), SortOn:=xlSortOnValues, Order:=xlAscending
                    .Apply
                End With
           Application.Goto .Range("A1")
           Dim lr As Long
           lr = .Cells(Rows.Count, 1).End(xlUp).Row
            .Range("a2:a" & lr + 1).NumberFormat = "0"
            .Range("b2:f" & lr + 1).NumberFormat = "@"
             .Range("h2:h" & lr + 1).NumberFormat = "General"
             .Range("i2:i" & lr + 1).NumberFormat = "0000"
             .Range("j2:j" & lr + 1).NumberFormat = "General"
              .Range("k2:k" & lr + 1).NumberFormat = "0.00"
            End With
            Next sh
           '----------------------------------------------------------------------------------------------
            wbResult.Worksheets("ورقة9").Range("g2:g" & lr + 1).NumberFormat = "0000" 'ورقه9
            wbResult.Worksheets("ورقة8").Range("g2:g" & lr + 1).NumberFormat = "0.00"  'ورقه8

            wb.Close SaveChanges:=False
            myFile = Dir
        Loop
        wbResult.Close SaveChanges:=True
    Application.ScreenUpdating = True
    MsgBox "Done...", 64
End Sub

الكود يعمل بشكل أكثر من رائع لكنى فى حاجة إلى مساعدة حضراتكم فى نقطة واحده فقط لا غير
وهى إضافة شرط لحذف الصفوف فى جميع المصنفات التى بداخل المجلد الرئيسى 
حال عدم إحتواء العمود G فى الورقة 8 وكذا العمود K فى الورقة 9 على أية قيم عددية
كيف يمكن تحقيق ذلك **** برجاء الإطلاع على الملفين بالمجلد الرئيسى لمعرفة ما أعنيه
الكود بداخل الملف TEST **** تقبلوا وافر تقديرى ***** واحترامى وجزاكم الله خيرا

 
 
 
  الرئيسى.rar   تحميل rar مرات التحميل :(4)
الحجم :(83.157) KB



أفضل إجابة مقدمة من hassona229 وهي:
وعليكم السلام ورحمه الله وبركاته
جرب هذا التعديل اخى الكريم

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب 
عرض الإجابة




30-09-2020 07:36 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif حذف صفوف إعتمادا على شرط
وعليكم السلام
يمكن اختبار القيمة العددية باستخدام الدالة IsNumeric 
مثال :
نفترض أن لديك في الخلية A1 القيمة 50 وتريد معرفة ما إذا كانت القيمة الموجودة في الخلية A1 رقمية (عددية) أم لا ، فيمكنك استخدام الكود بهذا الشكل
Sub Test()
    Dim x
    x = Range("A1").Value
    If Not IsEmpty(x) And IsNumeric(x) Then
        MsgBox "Cell A1 Has A Number", 64
    End If
End Sub

30-09-2020 11:27 صباحا
مشاهدة مشاركة منفردة [2]
أبو سجده
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-08-2017
رقم العضوية : 95
المشاركات : 222
الجنس : ذكر
تاريخ الميلاد : 2-2-1965
يتابعهم : 1
يتابعونه : 3
قوة السمعة : 328
 offline 
look/images/icons/i1.gif حذف صفوف إعتمادا على شرط
السلام عليكم أبو البراء 
تمام لكنى أرغب فى تضمين هذا الشرط من داخل الكود ومزيد من التوضيح
1 - لو أى خلية فى العمود G فى الورقة 8 فى جميع الملفات التى بداخل المجلد الرئيسى تحتوى على صفر يجب حذف هذا السطر أثناء عملية التصدير الى الملف المغلق
2 - لو أى خلية فى العمود K فى الورقة 9 فى جميع الملفات التى بداخل المجلد الرئيسى تحتوى على صفر يجب حذف هذا السطر أثناء عملية التصدير الى الملف المغلق
أرجو أن تكون الفكرة واضحة وأعتذر لأننى لم أجد وصفا أخر لتوضيح هذه النقطة ***** جزاكم الله خيرا وبارك فيكم جميعا

 

30-09-2020 11:50 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif حذف صفوف إعتمادا على شرط
يمكن بعد الانتهاء من عملية النقل للبيانات عمل فلترة بناءً على العمود الذي تريد وتستثني القيم الصفرية أو الفارغة
الجهاز لدي به مشاكل لذا لا أملك لك إلا مجرد أفكار للحلول ، وننتظر المشاركات للأخوة الأعضاء.

30-09-2020 08:41 مساء
مشاهدة مشاركة منفردة [4]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 798
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 10
قوة السمعة : 4030
عدد الإجابات: 110
 offline 
look/images/icons/i1.gif حذف صفوف إعتمادا على شرط
وعليكم السلام ورحمه الله وبركاته
جرب هذا التعديل اخى الكريم

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  test.xlsb   تحميل xlsb مرات التحميل :(7)
الحجم :(27.954) KB


30-09-2020 09:51 مساء
مشاهدة مشاركة منفردة [5]
أبو سجده
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-08-2017
رقم العضوية : 95
المشاركات : 222
الجنس : ذكر
تاريخ الميلاد : 2-2-1965
يتابعهم : 1
يتابعونه : 3
قوة السمعة : 328
 offline 
look/images/icons/i1.gif حذف صفوف إعتمادا على شرط
السلام عليكم جميعا ورحمة الله وبركاته
يا تكاتك يا حركاتك يا أبو حسونة
شوف حبيب قلبى سأحاول التوضيح بطريقة أخرى
فى الورقة 8 من المصنف رقم 1 الصف رقم 3 العمود G  قيمته صفر
فى الورقة 9 من المصنف رقم 1 الصفين رقم 5 و 9 العمود G  قيمتهما صفر
فى الورقة 8 من المصنف رقم 2 الصفين رقم 8 و 9 العمودK    قيمتهما صفر
فى الورقة 9 من المصنف رقم 2 الصف رقم 7 العمود K   قيمته صفر
المطلوب بحول الله تعالى وقل بسم الله الرحمن الرحيم أولا هتلاقى الدنيا ميت فل و 14 معاك بإذن الله
إحنا عايزين نصدر الملفات دى الى ملف النتائج بدون أى صفوف تحتوى على صفر وعلى حسب المثال  المرفق سيحتوى  ملف النتائج على 17 صف فى كل ورقة بعد تشغيل الكود
وهناك ملحوظة وهى مع تشغيل الكود يتم حذف روؤس الأعمدة فى ملف النتائج
أصلح الله بالك ورزقكم وإيانا من حيث لا نحتسب وجزاكم الله خيرا                          

 

01-10-2020 02:25 صباحا
مشاهدة مشاركة منفردة [6]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 798
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 10
قوة السمعة : 4030
عدد الإجابات: 110
 offline 
look/images/icons/i1.gif حذف صفوف إعتمادا على شرط
وعليكم السلام ورحمه الله وبركاته
جرب هذا التعديل اخى الكريم

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب 
 
 
  test.xlsb   تحميل xlsb مرات التحميل :(12)
الحجم :(27.936) KB



الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
صفوف ، إعتمادا ،


 










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

الساعة الآن 06:19 صباحا