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

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


اعلان هنا
ألعاب فلاش أون لاين
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا


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





ضبط كود ترحيل من صفحة الى عدة صفحات بإسم الصفحة

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



13-12-2019 05:45 مساء
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 329
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 498
الاعجاب : 33
 offline 
السلام عليكم اخوانى واحبائى الكرام ,كنت اعمل على هذا الملف وبه كود ترحيل من الصفحة الرئيسية Main الى الصفحات الأخرى بمجرد اختيار
اسم الصفحة من القائمة المنسدلة الموجودة بداية من B11:B55 فى صفحة Main وعندما اضغط على كلمة ترحيل يتم الترحيل بالفعل الى الصفحة المختارة بداية من النطاق c11:k55 , كل هذا كده كويس ولكن المشكلة كلما قمت بترحيل بيانات جديدة يتم حذف البيانات القديمة المرحلة من قبل فى الصفحة المرحل اليها ولكنى اريد عدم حذف البيانات المرحلة من قبل ولكن يرحل البيانات تحت بعضها
والكود المستخدم فى الملف من أعمال استاذنا الجليل ياسر خليل ابو البراء
Option Explicit
Sub TransferToRelatedSheets()
    Dim wks         As Worksheet
    Dim data        As Variant
    Dim item        As Variant
    Dim key         As Variant
    Dim dict        As Object
    Dim rng         As Range
    Dim rngBeg      As Range
    Dim rngEnd      As Range
    Dim cell        As Range
    Dim x           As Long
    Dim y           As Long

    Set wks = ThisWorkbook.Worksheets("Main")
    Set rngBeg = wks.Range("b11:k11")
    Set rngEnd = wks.Cells(Rows.Count, rngBeg.Column).End(xlUp)
    If rngEnd.Row < rngBeg.Row Then Exit Sub
    Set rng = wks.Range(rngBeg, rngEnd)
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Application.ScreenUpdating = False
        For Each cell In rng.Columns(1).Cells
            key = Trim(cell)
            item = cell.Resize(1, rng.Columns.Count).Value
     '      item(2, 8) = CLng(item(2, 8))
                        If Not dict.Exists(key) Then
                dict.Add key, item
            Else
                data = Application.Transpose(dict(key))
                x = UBound(data, 1)
                y = UBound(data, 2) + 1
                ReDim Preserve data(1 To x, 1 To y)
                    data = Application.Transpose(data)
                    For x = 1 To UBound(item, 2)
                    data(y, x) = item(1, x)
                Next x
                    dict(key) = data
            End If
        Next cell
    
        For Each item In dict.Items
            If WorksheetExists(CStr(item(1, 1))) Then
                x = UBound(item, 1)
                y = UBound(item, 2)
                Set rng = Worksheets(CStr(item(1, 1))).Range("b11:b55")
                rng.Resize(x, y).Value = item
            End If
        Next item
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
    Sheets("Main").Activate
    Range("a11:e55").ClearContents
    Range("g11:k55").ClearContents
End Sub

Function WorksheetExists(sheetName As String) As Boolean
    Dim sheet       As Worksheet
    Dim temp        As String

    temp = UCase(sheetName)
    WorksheetExists = False

    For Each sheet In Worksheets
        If temp = UCase(sheet.Name) Then
            WorksheetExists = True
            Exit Function
        End If
    Next sheet
End Function




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





13-12-2019 07:16 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8422
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 440
قوة السمعة : 24564
الاعجاب : 2765
 offline 
look/images/icons/i1.gif ضبط كود ترحيل من صفحة الى عدة صفحات بإسم الصفحة
وعليكم السلام أخي الكريم هاني
حاول إرفاق ملف مبسط فيه بعض أوراق العمل لنستطيع تجربة الكود ..
عموماً ابحث في الكود عن أي أسطر تقوم بمسح النطاق الذي سيتم الترحيل إليه والغي هذه الأسطر وجرب مرة أخرى.

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



13-12-2019 07:29 مساء
مشاهدة مشاركة منفردة [2]
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 329
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 498
الاعجاب : 33
 offline 
look/images/icons/i1.gif ضبط كود ترحيل من صفحة الى عدة صفحات بإسم الصفحة
بارك الله فيك استاذى الكريم
ولكنى حاولت ان اصل عل الحل بنفسى ولكن لم استطع جزاك الله كل خير وزادك الله استاذى الكريم من فضله
وهذا هو مثال مصغر من ملفى وارجو المساعدة من فضلك استاذى الكريم ولكم جزيل الشكر
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
 
  Transfer Data.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(110.511) KB





13-12-2019 08:12 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8422
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 440
قوة السمعة : 24564
الاعجاب : 2765
 offline 
look/images/icons/i1.gif ضبط كود ترحيل من صفحة الى عدة صفحات بإسم الصفحة
أخي الكريم هاني
سامحك الله
أرفقت ملف ليس به بيانات للعمل عليها .. يرجى دائماً وضع بيانات فيما يقرب من 5 صفوف على الأقل لنسطيع تجربة الكود 
عموماً حسب ما فهمت من طلبك جرب التعديل في الجزء التالي عله يفي بالغرض إن شاء الله
                x = UBound(item, 1)
                y = UBound(item, 2)
                
                With Worksheets(CStr(item(1, 1)))
                    Set rng = .Range("B" & .Cells(56, 2).End(xlUp).Row + 1)
                End With
                rng.Resize(x, y).Value = item

أثارت هذه المشاركة إعجاب: هانى على، ali mohamed ali، mostah،



13-12-2019 09:48 مساء
مشاهدة مشاركة منفردة [4]
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 329
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 498
الاعجاب : 33
 offline 
look/images/icons/i1.gif ضبط كود ترحيل من صفحة الى عدة صفحات بإسم الصفحة
أعذرنى استاذى الكريم
بارك الله فيك وزادك الله تعالى من فضله ,احسنت فأبدعت وهو المطلوب حقاً
أكرمك الله دنيا واخرى ووسع الله فى رزقك ورقك من حيث لا تحتسب واحسن الله الى اولادك واكرمك الله فيهم
اشكرا كثير استاذى الكريم

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



14-12-2019 08:01 صباحا
مشاهدة مشاركة منفردة [5]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8422
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 440
قوة السمعة : 24564
الاعجاب : 2765
 offline 
look/images/icons/i1.gif ضبط كود ترحيل من صفحة الى عدة صفحات بإسم الصفحة
بارك الله فيك أخي الغالي هاني والحمد لله أن تم المطلوب على خير
والحمد لله الذي بنعمته تتم الصالحات

142

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





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
السماح بترحيل بيانات الموظف عند ادخال رقم الامر وتاريخ مختلف شبل
8 190 YasserKhalil
ترحيل الغياب إلى أرشيف الغياب Khairi
4 68 YasserKhalil
طلب تعديل فى كود ترحيل و كود بحث mo7amed.2017
0 53 mo7amed.2017
ترحيل البيانات اتوماتيكيا الى عدد محدود من اوراق العمل بطريقة سهله وسريعه mostah
1 99 mostah
منع ترحيل بيانات صف مكرر من جدول الى جداول شبل
5 84 شبل

الكلمات الدلالية
ترحيل ، صفحة ، صفحات ، بإسم ، الصفحة ،


 







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

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

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