ترحيل حسب المنطقه بترتيب ابجدى وصفين فارغين قبل كل اسم مرحل

[ابوحمزه المصرى]

السلام عليكم ورحمة الله وبركاته

اسعد الله اوقاتكم

ارجوا من الاخوه الكرام التكرم والافاده بترحيل حسب المنطقه بترتيب ابجدى وصفين فارغين قبل كل اسم مرحل مرفق المثال ترحيل حسب المنطقه بترتيب ابجدى وصفين فارغين قبل كل اسم مرحل.rar

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

أخي الكريم صلاح

ماذا تقصد بالترتيب الأبجدي ؟ هل الترتيب الأبجدي للأسماء التي يتم ترحيلها أم تقصد ترتيب أبجدي للمناطق التي سترحل؟

وأمر آخر : هل أوراق العمل التي سيتم الترحيل إليها موجودة أم أنك تطلب أن يتم إنشاء أوراق العمل ؟

نرجو الإيضاح ليستطيع إخوانك بالمنتدى تقديم المساعدة

تقبل تحياتي

 

[ابوحمزه المصرى]

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

تم تعديل يناير 15, 2016 بواسطه صلاح المصرى

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

أخي الكريم صلاح

أعتذر بشكل مبدئي حيث أنني قمت بتنسيق المصنف المرفق بما أحب أن أره منسقاً (مرض نفسي بعيد عنك) ..معرفش أشتغل على ملف غير لما أنسقه بأسلوبي الأول .. لكن تبقى هيكلة الملف كما هي لا تقلق

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

Sub TransferByRegion()
    Dim Ws      As Worksheet
    Dim Sh      As Worksheet
    Dim Cel     As Range
    Dim LR      As Integer
    Dim Last    As Integer
    
    Set Ws = Sheet1
    
    Application.ScreenUpdating = False
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name <> "العملاء" Then
                With Sh.Range("A1:C" & Sh.Cells(Rows.Count, 1).End(xlUp).Row)
                    .Offset(1).ClearContents
                    .Borders.LineStyle = xlNone
                End With
            End If
        Next Sh
        
        With Ws
            LR = .Cells(Rows.Count, 1).End(xlUp).Row
            .Range("A1").CurrentRegion.Copy .Range("H1")
            Range("H1:J" & LR).Sort Key1:=Range("I1:I" & LR), Order1:=xlAscending, Key2:=Range("J1:J" & LR), Order2:=xlAscending, Header:=xlYes
            
            For Each Cel In Ws.Range("I2:I" & LR)
                Last = Sheets(Cel.Value).Cells(Rows.Count, 2).End(xlUp).Row + 3
                Sheets(Cel.Value).Range("B" & Last).Resize(1, 2).Value = Cel.Resize(1, 2).Value
                Sheets(Cel.Value).Range("A" & Last).Value = Application.WorksheetFunction.CountA(Sheets(Cel.Value).Columns(2)) - 1
            Next Cel
            
            .Columns("H:J").Delete
        End With
        
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name <> "العملاء" Then
                With Sh.Range("A1:C" & Sh.Cells(Rows.Count, 1).End(xlUp).Row)
                    .Borders.Weight = xlThin
                    .BorderAround Weight:=xlThin
                End With
            End If
        Next Sh
        
        MsgBox "Done. God Bless You Salah", 64
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

Transfer Data Based On Region & Insert Two Empty Rows YasserKhalil.rar

[ابوحمزه المصرى]

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