الترحيل حسب خلية العمود o

**حسين مامون** · أغسطس 15, 2016

السلام عليكم

اريد ترحيل بيانات من شيتtafasil الى الشيتات الاخرى حسب المكتوب في خلايا العمود. O

المرفق فيه توضيح للمطلوب

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

الترحيل حسب الموقع.zip

**سليم حاصبيا** · أغسطس 15, 2016

ربما كان المطلوب

الترحيل حسب الموقعsalim.rar

**حسين مامون** · أغسطس 15, 2016

شكرا استاد هذا هو المطلوب ولكن الشيت ايت المودن لم تستقبل بيانات

تحياتي

**سليم حاصبيا** · أغسطس 15, 2016

رتب الجدول عي هذا الشبت ابتداءً من الخلية A وحتى الخية D

مثل باقي الصفحات

**حسين مامون** · أغسطس 15, 2016

شكرا استاد

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

الكود يعمل كما اريد الف الف شكر

ياسر خليل أبو البراء · أغسطس 16, 2016

أخي العزيز سليم

بارك الله فيك وجزيت خير الجزاء

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

**سليم حاصبيا** · أغسطس 16, 2016

منذ ساعه, ياسر خليل أبو البراء said:

أخي العزيز سليم

بارك الله فيك وجزيت خير الجزاء

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

مشكور اخي ياسر على هذه الملاحظة القيمة

تم التعديل على الكود المذكور

الترحيل حسب الموقعsalim1.rar

ياسر خليل أبو البراء · أغسطس 16, 2016

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

ولاحظ أنه بعد تنفيذ الكود إذا تم مسح النطاقات تظل الأوراق الأربعة محددة ..!!

وسؤال خطر ببالي : ماذا لو كان العمود O يحتوي على قيم ليس لها أوراق عمل ؟؟!! .. ما هو المطوب في هذه الحالة : أن يتم تخطي القيمة وتجاهلها أم يتم إنشاء ورقة عمل جديدة وتنقل إليها البيانات؟ أم يتم تخيير المستخدم فيما بين الأمرين؟

**سليم حاصبيا** · أغسطس 16, 2016

16 ساعات مضت, ياسر خليل أبو البراء said:

أخي العزيز سليم

بارك الله فيك وجزيت خير الجزاء

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

مشكور اخي ياسر على هذه الملاحظة القيمة

تم التعديل على الكود المذكور

تم التعديل مرة اخرى بواسطة هذا الكود

Sub CreateSheets()

    Dim ws As Worksheet
    Dim K As Range
    Dim ListSh As Range
Application.ScreenUpdating = False
    With Worksheets("tafasil")
        Set ListSh = .Range("o2:o" & .Cells(.Rows.Count, "o").End(xlUp).Row)
    End With

    On Error Resume Next
    For Each K In ListSh
    Worksheets("tafasil").Activate

        If Len(Trim(K.Value)) > 0 Then
        y = Worksheets(Trim(K.Value)).Name
        t = Application.CountIf(Range("o2:o" & K.Row), Trim(K.Value))
        If IsEmpty(y) And t = 1 Then
        Worksheets.add(After:=Worksheets(Worksheets.Count)).Name = K.Value

        ActiveSheet.Range("a1:d1") = Array("الاسم", "الرقم", "الفرق", "الموقع")

           '============================================

            End If
          y = Empty
        End If
      Next K
      Application.ScreenUpdating = True
    Worksheets("tafasil").Select
End Sub

و تغيير مسح البيانات الى هذا الكود

Sub del_data()
For mh = 2 To Sheets.Count
   Sheets(mh).Range("A2:d5000").ClearContents
   Next
    Sheets("tafasil").Select
    Range("a2").Select

End Sub

و الكود النهائي الى هذا الكود


Sub AddValues()
Dim My_sheet As Worksheet
Dim i As Single
'=============================
Application.ScreenUpdating = False
CreateSheets
answer = MsgBox("هل تريد مسح البيانات في الاوراق الباقية أولاً ", vbQuestion + vbYesNo + vbMsgBoxRtlReading)
   If answer = 6 Then del_data
   lr_MAIN = Sheets("tafasil").Cells(Rows.Count, 1).End(3).Row
   If lr_MAIN < 2 Then lr_MAIN = 2
   For K = 2 To lr_MAIN
     '==========================================
      On Error Resume Next
    Set My_sheet = Sheets("" & Sheets("tafasil").Range("O" & K))
    If Sheets("tafasil").Range("O" & K) = "" Then GoTo 1
     '==========================================
      With My_sheet

            i = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & i) = Sheets("tafasil").Range("A" & K)
                .Range("b" & i) = Sheets("tafasil").Range("b" & K)
                .Range("c" & i) = Sheets("tafasil").Range("e" & K)
                .Range("d" & i) = Sheets("tafasil").Range("O" & K)
               .Range("a2").Select
      End With
         '==========================================
1:
   Next
   Application.ScreenUpdating = True
Sheets("tafasil").Range("a1").Select

End Sub

ليصبح الشكل النهائي للملف هكذا

الترحيل حسب الموقعsalim2.rar

تم تعديل أغسطس 16, 2016 بواسطه سليم حاصبيا

ياسر خليل أبو البراء · أغسطس 17, 2016

جميل ورائع أخي الحبيب سليم

كمل جميلك ..

عند عدم وجود ورقة عمل يتم إنشاء ورقة عمل جديدة ..هلا خيرت المستخدم إذا كان يريد ورقة العمل أم لا؟

وأمر آخر يتم نسخ كافة عناوين الحقول عند إنشاء ورقة عمل جديدة (لاحظ هذه النقطة)

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

تقبل وافر تقديري واحترامي

**حسين مامون** · أغسطس 17, 2016

السلام عليكم اشكر الاخوة الافاضل على تجاوبهم

نعم هذه فكرة جيدة لانني اريد تنفيذ هذه العملية

مرة كل شهر وحفظها في مجلد

هل يمكن التعديل على الكود هناك خلل ؟

1 ينسخ عناوين الجدول كما هي في الصفحة الرءيسية

2 لايفوم بانشاء جميع الشيتات المطلوبة

3 الصفحة من اليمين الى اليسار

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

تم تعديل أغسطس 17, 2016 بواسطه حسين22

ياسر خليل أبو البراء · أغسطس 17, 2016

سؤال : هل أوراق العمل الموجودة سيتم إضافة بيانات لها أم أن العملية تتم مرة واحدة وفقط ..

إذا كان الأمر كذلك فلما لا يكون مبدأ الكود إنشاء أوراق عمل جديدة ووضع البيانات بها

**سليم حاصبيا** · أغسطس 17, 2016

10 ساعات مضت, ياسر خليل أبو البراء said:

جميل ورائع أخي الحبيب سليم

كمل جميلك ..

عند عدم وجود ورقة عمل يتم إنشاء ورقة عمل جديدة ..هلا خيرت المستخدم إذا كان يريد ورقة العمل أم لا؟

وأمر آخر يتم نسخ كافة عناوين الحقول عند إنشاء ورقة عمل جديدة (لاحظ هذه النقطة)

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

تقبل وافر تقديري واحترامي

تم التعديل مرة ثالثة

الترحيل حسب الموقعsalim3.rar

ياسر خليل أبو البراء · أغسطس 17, 2016

بارك الله فيك أخي الغالي سليم

كم أعشق حلولك الممتازة والرائعة

تقبل وافر تقديري واحترامي

**حسين مامون** · أغسطس 17, 2016

اشكركم اخواني هذا راءع جزاكم الله خيرا

ياسر خليل أبو البراء · أغسطس 17, 2016

وإثراءً للموضوع هذا كود آخر كنت قد جهزته وانتظرت أن يصل أخي وحبيبي سليم لخط النهاية قبلي ..

الكود يوضع في موديول عادي

Sub TransferData()
    Dim DictPerson As Object, DictSheet As Object, rng As Range, mtx(), isFound As Boolean
    Dim I As Long, v1 As Variant, v2 As Variant

    Application.ScreenUpdating = False
        Set rng = Sheets("Tafasil").Range("A1:O" & Sheets("Tafasil").Cells(Rows.Count, "O").End(xlUp).Row)
        mtx = rng.Value
    
        Set DictPerson = CreateObject("Scripting.Dictionary")
        For I = 2 To UBound(mtx, 1)
            If Not DictPerson.Exists(mtx(I, 15)) Then DictPerson.Add mtx(I, 15), mtx(I, 15)
        Next I
    
        Set DictSheet = CreateObject("Scripting.Dictionary")
        For I = 1 To Worksheets.Count
            If Not DictSheet.Exists(Worksheets(I).Name) Then DictSheet.Add Worksheets(I).Name, Worksheets(I).Name
        Next I
        DictSheet.Remove ("Tafasil")
    
        For Each v1 In DictPerson
            isFound = False
            For Each v2 In DictSheet
                If v1 = v2 Then
                    isFound = True
                    Exit For
                End If
            Next v2
            If Not isFound Then
                If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then
                    Worksheets.Add After:=Sheets("Tafasil")
                    ActiveSheet.Name = v1
                    ActiveSheet.DisplayRightToLeft = True
                    DictSheet.Add v1, v1
                End If
            End If
        Next v1
    
        For Each v1 In DictSheet
            Sheets(v1).Cells.Clear
            Sheets(v1).Range("A1").Resize(1, 4).Value = Array("الاسم", "الرقم", "الفرق", "الموقع")
    
            rng.AutoFilter field:=15, Criteria1:=v1
    
            With rng.Offset(1)
                .Columns("A:B").SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("A2").PasteSpecial xlPasteValues
                .Columns(5).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("C2").PasteSpecial xlPasteValues
                .Columns(15).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("D2").PasteSpecial xlPasteValues
            End With
    
            With Sheets(v1)
                .Range("A1").CurrentRegion.Borders.Value = 1
                .Range("A1").Resize(1, 4).Font.Bold = True
                .Cells.RowHeight = 19
                .Cells.HorizontalAlignment = xlCenter: .Cells.VerticalAlignment = xlCenter
                .Columns(1).ColumnWidth = 18: .Columns("B:C").ColumnWidth = 10: .Columns(4).ColumnWidth = 13
            End With
        Next v1
    
        rng.AutoFilter
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

تقبل تحياتي

**سليم حاصبيا** · أغسطس 17, 2016

10 دقائق مضت, ياسر خليل أبو البراء said:

وإثراءً للموضوع هذا كود آخر كنت قد جهزته وانتظرت أن يصل أخي وحبيبي سليم لخط النهاية قبلي ..

الكود يوضع في موديول عادي


Sub TransferData()
    Dim DictPerson As Object, DictSheet As Object, rng As Range, mtx(), isFound As Boolean
    Dim I As Long, v1 As Variant, v2 As Variant

    Application.ScreenUpdating = False
        Set rng = Sheets("Tafasil").Range("A1:O" & Sheets("Tafasil").Cells(Rows.Count, "O").End(xlUp).Row)
        mtx = rng.Value
    
        Set DictPerson = CreateObject("Scripting.Dictionary")
        For I = 2 To UBound(mtx, 1)
            If Not DictPerson.Exists(mtx(I, 15)) Then DictPerson.Add mtx(I, 15), mtx(I, 15)
        Next I
    
        Set DictSheet = CreateObject("Scripting.Dictionary")
        For I = 1 To Worksheets.Count
            If Not DictSheet.Exists(Worksheets(I).Name) Then DictSheet.Add Worksheets(I).Name, Worksheets(I).Name
        Next I
        DictSheet.Remove ("Tafasil")
    
        For Each v1 In DictPerson
            isFound = False
            For Each v2 In DictSheet
                If v1 = v2 Then
                    isFound = True
                    Exit For
                End If
            Next v2
            If Not isFound Then
                If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then
                    Worksheets.Add After:=Sheets("Tafasil")
                    ActiveSheet.Name = v1
                    ActiveSheet.DisplayRightToLeft = True
                    DictSheet.Add v1, v1
                End If
            End If
        Next v1
    
        For Each v1 In DictSheet
            Sheets(v1).Cells.Clear
            Sheets(v1).Range("A1").Resize(1, 4).Value = Array("الاسم", "الرقم", "الفرق", "الموقع")
    
            rng.AutoFilter field:=15, Criteria1:=v1
    
            With rng.Offset(1)
                .Columns("A:B").SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("A2").PasteSpecial xlPasteValues
                .Columns(5).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("C2").PasteSpecial xlPasteValues
                .Columns(15).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("D2").PasteSpecial xlPasteValues
            End With
    
            With Sheets(v1)
                .Range("A1").CurrentRegion.Borders.Value = 1
                .Range("A1").Resize(1, 4).Font.Bold = True
                .Cells.RowHeight = 19
                .Cells.HorizontalAlignment = xlCenter: .Cells.VerticalAlignment = xlCenter
                .Columns(1).ColumnWidth = 18: .Columns("B:C").ColumnWidth = 10: .Columns(4).ColumnWidth = 13
            End With
        Next v1
    
        rng.AutoFilter
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

تقبل تحياتي

هو انت فين مخبي الحاجات دي كلها

ياسر خليل أبو البراء · أغسطس 17, 2016

ياما في الجراب يا حاوي .. :wink2:

كله بفضل الله عزوجل .. لدي مكتبة تجميعية لعدد كبير من الأكواد أطوعها في تلبية الطلبات بحيث تلبي جميع الاحتياجات

وافر تقديري واحترامي

**حسين مامون** · أغسطس 17, 2016

السلام عليكم

اخواني الكود لايعمل وهذه صورة عن مصدر الخطأ

تم تعديل أغسطس 17, 2016 بواسطه حسين22

**حسين مامون** · أغسطس 17, 2016

**حسين مامون** · أغسطس 17, 2016

قمت بمسح هذان السطر ين من الكود وهو الان يعمل كما يجب

'        DictSheet.Remove ("Tafasil")
         ' Sheets(v1).Cells.Clear

حفظكم الله يا اسادذتنا ورعاكم

**حسين مامون** · أغسطس 17, 2016

استاذ

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

انظر المرفق

الترحيل حسب الموقع hous.rar

**حسين مامون** · أغسطس 18, 2016

12 ساعات مضت, حسين22 said:

استاذ

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

انظر المرفق

الترحيل حسب الموقع hous.rar

اساتذتي المحترمين

سليم و أبو البراء

هل موضوعي مفهوم..

ياسر خليل أبو البراء · أغسطس 18, 2016

أخي الكريم حسين

طلبك في مشاركتك الأخيرة مختلف عن الموضوع ..

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

لا يجب أن تتداخل الموضوعات لكي يسهل على الباحث فيما بعد الوصول لمبتغاه بسهولة دون تداخل الموضوعات

تقبل تحياتي

**حسين مامون** · أغسطس 18, 2016

شكرا أستاذ على النصائح القيمة

تسجيل الدخول

الترحيل حسب خلية العمود o

الردود الموصى بها

حسين مامون

سليم حاصبيا

حسين مامون

سليم حاصبيا

حسين مامون

ياسر خليل أبو البراء

سليم حاصبيا

ياسر خليل أبو البراء

سليم حاصبيا

ياسر خليل أبو البراء

حسين مامون

ياسر خليل أبو البراء

سليم حاصبيا

ياسر خليل أبو البراء

حسين مامون

ياسر خليل أبو البراء

سليم حاصبيا

ياسر خليل أبو البراء

حسين مامون

حسين مامون

حسين مامون

حسين مامون

حسين مامون

ياسر خليل أبو البراء

حسين مامون

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information