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



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





نقل البيانات إعتمادا على شرط مع إدراج عدد محدد من الصفوف فى نقاط محددة

السلام عليكم جميعا ورحمته الله وبركاته بداية اسمحوا لى أن أتقدم بخالص تهنئتى القلبية و لجميع السادة القائمين على أكاديم ..




07-09-2017 02:53 مساء
مشاهدة مشاركة منفردة [61]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 3096
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 11
يتابعهم : 0
يتابعونه : 257
قوة السمعة : 8698
الاعجاب : 2907
 offline 
look/images/icons/i1.gif نقل البيانات إعتمادا على شرط مع إدراج عدد محدد من الصفوف فى نقاط محددة
وعليكم السلام أخي العزيز أبو عبد الرحمن
الفضل لله وحده وأما أنا وأنت فليس لنا فضل .. وكل هذا بتوفيقه سبحانه وتعالى

بالنسبة لآخر نقطة لأن الموضوع استغرق وقت ليس بالقليل ، قم بوضع السطر التالي
.Range("A" & (iRows + iNum) * i - (iRows - 1)).Offset(iRows + 2).Resize(1, 6).Font.Bold = True

بعد هذا السطر مباشرةً
For i = 1 To x


وإن شاء الله بعد ما تظبط الكود كما تريد يرجى إعادة نشر الكود أو وضع الملف المرفق الأخير ليستفيد منه الجميع
تقبل تحياتي





07-09-2017 08:54 مساء
مشاهدة مشاركة منفردة [62]
سعيد بيرم ابوعبدالرحمن
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-08-2017
رقم العضوية : 95
المشاركات : 71
الجنس : ذكر
تاريخ الميلاد : 2-2-1965
يتابعهم : 1
يتابعونه : 3
قوة السمعة : 61
الاعجاب : 24
 offline 
look/images/icons/i1.gif نقل البيانات إعتمادا على شرط مع إدراج عدد محدد من الصفوف فى نقاط محددة
اخى وحبيبى فى الله ابو البراء
السلام عليكم ورحمته الله وبركاته
زادكم الله تعالى وإيانا من فضله وزاكم أدبا وتواضعا
كيف يمكن إزالة التبويب Falcon Academy وكذا الرمز Bairum 
من شريط الادوات السريع حيث قمت بالخطوات التالية دون جدوى
Excel Option
Customize
Customize Quick Access Toolbar
Choose commands  from 
اعتقد ان هناك سرا أخر يمنع تنفيذ الكود حال نقل الكود فى ملف جديد 
ربما والله اعلى وأعلم ان الرمز Bairum  مرتبط برمجيا بأمرا ما
ارجو الافادة *** حيث انتهيت تماما من ضبط كافة الامور بالكود بإستثناء هذه الجزئية
نظرا لارتباط هذا الكود المميز بأكواد أخرى يتم تنفيذها اولا بأمرالله تعالى ثم بأمر واحد
تقبل وافر تقديرى واحترامى وجزاكم الله خيرا


 


تم تحرير المشاركة بواسطة :سعيد بيرم ابوعبدالرحمن
بتاريخ:08-09-2017 12:12 صباحا






07-09-2017 10:17 مساء
مشاهدة مشاركة منفردة [63]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 3096
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 11
يتابعهم : 0
يتابعونه : 257
قوة السمعة : 8698
الاعجاب : 2907
 offline 
look/images/icons/lock.gif نقل البيانات إعتمادا على شرط مع إدراج عدد محدد من الصفوف فى نقاط محددة
أخي العزيز أبو عبد الرحمن
لن أخبرك بالنقطة الأولى وهي إزالة التبويب المذكور حفاظاً على حقوق الملكية الفكرية smile
بالطبع ليس سراً ويوجد موضوع قمت فيه بشرح تفصيلي لكيفية إنشاء تبويب مخصص ، وبنفس البرنامج المذكور في الموضوع تقوم بفتح الملف بالبرنامج ثم كليك يمين على CustomUI.xml ثم تختار Remove ، ثم تنقر زر الحفظ Save كما بالصورة التالية
MjY4MjYwMQ3636Help

أما بخصوص نقل الكود لملف جديد فإزالة التبويب لن تحل المشكلة (أيون والله زي ما بقولك كدا)
ولكن يكمن الحل في نقطة بسيطة للغاية (صدقني والله بسيطة للغاية) >> ما إنت لو متابع الموضوع اللي شرحت فيه كيفية إنشاء تبويب مخصص كنت ممكن تعرفها لوحدك smile

عموماً مش هطول عليك قول طول (قلت طول : الله ينور عليك)
روح للكود في محرر الأكواد
في أول سطر في الكود بعد كلمة Sub فيه اسم الإجراء الفرعي أو الكود وبعدين بين قوسين فيه شوية كلمات غريبة كدا ملناش دعوة بيها .. شيل بقا شوية الكلمات الغريبة دي ، وانقل الكود لأي ملف يا غالي
MzA5ODA3MQ7878001
أو ممكن تستغنى عن الكود دا لأن دا عشان نحسب بيه زمن التنفيذ للكود ، فتقوم ايه ..؟ تشيل أول سطر فوق خالص في الكود (سطر الإعلان) اللي أوله Public Declare
وتشيل الكود اللي اسمه RUNTHISCODE وتشيل كلمة Private من اسم الكود اللي بعديه
وتنقل الكود من أول كلمة Sub TransferUsingArrays لحد آخر سطر .. وبس خلاص
(خلصانة بغتاتة مني  laugh wink_3

تقبل تحياتي
 
 
 


أثارت هذه المشاركة إعجاب: سعيد بيرم ابوعبدالرحمن،




08-09-2017 12:52 صباحا
مشاهدة مشاركة منفردة [64]
سعيد بيرم ابوعبدالرحمن
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-08-2017
رقم العضوية : 95
المشاركات : 71
الجنس : ذكر
تاريخ الميلاد : 2-2-1965
يتابعهم : 1
يتابعونه : 3
قوة السمعة : 61
الاعجاب : 24
 offline 
look/images/icons/i1.gif نقل البيانات إعتمادا على شرط مع إدراج عدد محدد من الصفوف فى نقاط محددة
اخى العزيز الغالى ابو البراء  3   123  111
السلام عليكم ورحمته الله وبركاته
عمرها ماخلصت بغتاته وبالذات مع سعيد بالعكس والله العظيم
 خلصت بقمة الشياكة والأدب والذوق من أخ عزيز وصديق غالى ذو خلق رفيع المستوى وده راجع لأصلك الطيب
لان الموضوع اجتمع على النية الصافية
لسعيد والقلب الصافى لياسر " مع حفظ الألقاب"
اهم مايميز هذا الموضوع وبصدق اننى تعلمت الكثير مما أتاك الله تعالى من فضله وأدركت ألية العمل تماما
لانك أعطيتنى الفرصة لاكثر من مرة للبحث والتنقيب من بين سطور هذا العمل الرائع
المحتسب لك بإذن الله فى موازين حسناتك يوم الحشر الأعظم *** رزقنى الله واياكم من حيث لانحتسب
اليك اخى ابو البراء الكود فى صورته النهائية *** لكم منى أطيب التمنيات القلبية بدوام الصحة والعافية
وعذرا اخى العزيز الغالى ان كنت قد أثقلت عليك بكثرة أسئلتى ولكن لاحياء فى طلب العلم
تقبل وافر تقديرى واحترامى **** وجزاكم الله خيرا       142

Option Explicit

Sub test()
Dim ws As Worksheet, sh As Worksheet, a As Variant, b As Variant, c As Variant, d As Variant, r As Variant
Dim rng As Range, cell As Range, oRange As Range
Dim s As String, x  As Long, i As Long, j As Long, k As Long, m As Long, n As Long
On Error Resume Next
Application.ScreenUpdating = False
    
    Const strTot    As String = "الإجمالي"
    Const strH1     As String = "مختص"
    Const strH2     As String = "مراجع أول"
    Const strH3     As String = "مراجع ثان"
    Const strH4     As String = "يعتمد"
    Const strH5     As String = "إجمالي ما قبله"
    
    Const strN1     As String = "الصقر"
    Const strN2     As String = " الصقر"
    Const strN3     As String = "الصقر"
    Const strN4     As String = "الصقر"
    Const strN5     As String = " الصقر"
    Const strN6     As String = "الصقر"
    Const strN7     As String = "الاستاذ الفاضل ياسر خليل ابو البراء"
    Const iRows     As Long = 30
    Const iNum      As Long = 6

    Application.ScreenUpdating = False
        Set ws = Sheets("الرئيسية")
        Set sh = Sheets("Output")
        s = "اكاديمية"
        x = Application.WorksheetFunction.CountIf(ws.Columns(9), s)
        x = Application.RoundUp(x / iRows, 0)
        a = ws.Range("A8:R" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
        ReDim b(1 To x * (iRows + iNum), 1 To 6)
    
        For i = LBound(a, 1) To UBound(a, 1)
            If a(i, 9) = s Then
                k = k + 1
                If k Mod (iRows + iNum) = iRows + 1 Then
                    b(k, 2) = strTot
                    b(k, 6) = "=SUM(R[-" & iRows + 1 & "]C:R[-1]C)"
                    b(k + 1, 2) = strH1
                    b(k + 1, 3) = strH2
                    b(k + 1, 4) = strH3
                    b(k + 1, 6) = strH4
                    b(k + 5, 2) = strH5
                    b(k + 5, 6) = "=R[-5]C"
                    k = k + iNum
                  End If
    
                For j = 1 To 5
                    b(k, j) = CStr(a(i, j))
                Next j
                b(k, 6) = a(i, 18)
            End If
        Next i
    
        If k = 0 Then Exit Sub
        If k Mod (iRows + iNum) <> 0 Then
            k = k + (iRows + 1) - k Mod (iRows + iNum)
            b(k, 2) = strTot
            b(k, 6) = "=SUM(R[-" & iRows + 1 & "]C:R[-1]C)"
            b(k + 1, 2) = strH1
            b(k + 1, 3) = strH2
            b(k + 1, 4) = strH3
            b(k + 1, 6) = strH4
        End If
    
        With sh
            .Cells.Clear: .Rows.Delete
            .DisplayRightToLeft = True
            .PageSetup.PrintTitleRows = "$1:$7"
    
            With .Cells
                .ReadingOrder = xlRTL: .HorizontalAlignment = xlRight: .VerticalAlignment = xlCenter
            End With
    
            With .Range("A1")
                .Value = strN1: .Resize(1, 2).HorizontalAlignment = xlCenterAcrossSelection
                .Offset(1).Value = strN2: .Offset(1).Resize(1, 2).HorizontalAlignment = xlCenterAcrossSelection
                .Offset(1).Value = strN2: .Offset(1).Resize(1, 2).Columns("A").ColumnWidth = 25
                
                .Offset(2).Value = strN3: .Offset(2).Resize(1, 2).HorizontalAlignment = xlCenterAcrossSelection
                .Offset(3).Value = strN5: .Offset(3).Resize(1, 6).HorizontalAlignment = xlCenterAcrossSelection
                .Offset(4).Value = strN6: .Offset(4).Resize(1, 6).HorizontalAlignment = xlCenterAcrossSelection
                .Offset(5).Value = strN7: .Offset(5).Resize(1, 6).HorizontalAlignment = xlCenterAcrossSelection
                .Offset(1, 3).Value = strN4: .Offset(1, 3).Resize(1, 3).HorizontalAlignment = xlCenterAcrossSelection
                .Resize(6, 6).Font.Bold = True
                .Resize(6, 6).Font.Size = 13
            End With
    
            With .Range("A7")
                .Resize(1, 6).Value = Array("م", "القومى", "قائمة الاسماء", "الجهة", "كود", "جملة ")
                .Resize(1, 6).HorizontalAlignment = xlCenter
                .Resize(1, 6).Font.Bold = True
                .Offset(, 1).EntireColumn.NumberFormat = "@"
                .Offset(, 5).EntireColumn.NumberFormat = "0.00"
                .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
            End With
    
            For i = 1 To x
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Offset(iRows + 2).Resize(1, 6).Font.Bold = True
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Offset(iRows + 2).Resize(1, 6).HorizontalAlignment = xlCenter
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Resize((iRows + 2), 6).Borders.Value = 1
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Resize((iRows + 2), 6).RowHeight = 20
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Resize((iRows + 2), 6).Font.Size = 14
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Resize((iRows + 2), 6).Font.Bold = True
                .Range("A" & (iRows + iNum) * i - (iRows - 1)).Resize((iRows + 2), 6).Font.Name = "Times New Roman"
                .Columns(1).NumberFormat = "0"
                .Columns(5).NumberFormat = "0"
                .Columns(6).NumberFormat = "0.00"
                
                
                If oRange Is Nothing Then Set oRange = .Range("A" & (iRows + iNum) * i - (iRows - 1)) Else Set oRange = Union(oRange, .Range("A" & (iRows + iNum) * i - (iRows - 1)))
                If oRange Is Nothing Then Set oRange = .Range("A" & (iRows + iNum) * i + 2) Else Set oRange = Union(oRange, .Range("A" & (iRows + iNum) * i + 2))
                If i > 1 Then .HPageBreaks.Add Before:=.Range("A" & (iRows + iNum) * i - (iRows - 1))
            Next i
    
            If Not oRange Is Nothing Then oRange.EntireRow.RowHeight = 30
            c = Array(1, 2, 3, 4, 5, 6): d = Array(6, 19, 33, 15, 8, 13)
            For i = LBound(c) To UBound(c)
                Columns(c(i)).ColumnWidth = d(i)
            Next i
    
            With sh
                m = .Range("B" & Rows.Count).End(xlUp).Row
                .AutoFilterMode = False
                With .Range("A7:F" & m)
                    .AutoFilter
                    .AutoFilter Field:=5, Criteria1:="<>"
                    .Sort Key1:=.Range("D7"), Order1:=xlAscending, Key2:=.Range("C7"), Order2:=xlAscending, Header:=xlYes
                End With
                .AutoFilterMode = False
    
                a = .Range("A8:B" & m).Value
                For i = LBound(a, 1) To UBound(a, 1)
                    If a(i, 2) <> vbNullString And a(i, 2) <> strTot And a(i, 2) <> strH1 And a(i, 2) <> strH5 Then
                        n = n + 1: a(i, 1) = n
                    End If
                Next i
                .Range("A8:B" & m).Value = a
            End With
        End With
    ActiveSheet.PrintOut
    Application.ScreenUpdating = True
End Sub

أثارت هذه المشاركة إعجاب: YasserKhalil،




08-09-2017 09:06 صباحا
مشاهدة مشاركة منفردة [65]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 3096
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 11
يتابعهم : 0
يتابعونه : 257
قوة السمعة : 8698
الاعجاب : 2907
 offline 
look/images/icons/i1.gif نقل البيانات إعتمادا على شرط مع إدراج عدد محدد من الصفوف فى نقاط محددة
وعليكم السلام أخي الغالي أبو عبد الرحمن
بارك الله فيك وجزاك الله خيراً على كلماتك الرقيقة ودعائك الطيب المبارك
وأدعو الله أن يجمعنا في مستقر رحمته يوم القيامة

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






المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
نقل الطلبة الى الناجحين الى مستوى اعلا مع ترك معيدين malik
10 353 YasserKhalil
مساعدة فى نقل معادلة من شيت الى شيت اخر sobhy30003
2 146 sobhy30003
نقل (ترحيل) البيانات عند الضغط على زر الترحيل الى شيت معين زيد2017
3 249 زيد2017
معادلة نقل مبلغ السلفة ومبلغ الشراء محمد لؤي
0 131 محمد لؤي
نقل البيانات من الرئيسية مع إدراج عدد محدد من الصفوف فى نقاط محددة لاكثر من ورقة سعيد بيرم ابوعبدالرحمن
10 316 YasserKhalil

الكلمات الدلالية
لا يوجد كلمات دلالية ..


 







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



الساعة الآن 11:01 مساء

أعلن هنا
أعلن هنا
أعلن هنا