اذهب الي المحتوي
أوفيسنا

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

حسين مامون

بواسطه حسين مامون
في منتدى الاكسيل Excel

 مشاركة

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

حسين مامون

حسين مامون

قام بنشر
قام بنشر

السلام عليكم

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

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

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

 

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

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

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

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

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

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

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

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

 

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

  • Like 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

 

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

 

  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر (معدل)
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

تم تعديل بواسطه سليم حاصبيا
  • Like 2
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

كمل جميلك ..

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

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

 

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

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

  • Like 2
رابط هذا التعليق
شارك
حسين مامون

حسين مامون

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

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

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

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

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

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

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

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

تم تعديل بواسطه حسين22
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

 

  • Like 2
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

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

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

كمل جميلك ..

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

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

 

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

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

تقبل تحياتي

  • Like 2
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر
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

تقبل تحياتي

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

  • Like 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

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

  • Like 2
رابط هذا التعليق
شارك
حسين مامون

حسين مامون

قام بنشر
  • الكاتب
قام بنشر
12 ساعات مضت, حسين22 said:

استاذ

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

انظر المرفق

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

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

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

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

 

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

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

 

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

تقبل تحياتي

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept