rami91 قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 31, 2012 السلام عليكم : المطلوب في المرفقات وشكرا لكم . Book2.zip رابط هذا التعليق شارك More sharing options...
أبو حنــــين قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 31, 2012 استعمل هذا الماكرو Sub AbouHanine() Application.ScreenUpdating = False Dim cl As Range For Each cl In Range("A1:A14") For i = 1 To Sheets.Count Range("A1").AutoFilter Field:=1, Criteria1:=cl If Sheets(i).Name = cl Then Range("A2:A14").Copy With Sheets(i) .Select: .Range("A1").Select: .Paste Application.CutCopyMode = False: Sheets(1).Select: Selection.AutoFilter End With: End If Next: Next Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
جمال عبد السميع قام بنشر نوفمبر 1, 2012 مشاركة قام بنشر نوفمبر 1, 2012 (معدل) بعد إذن أستاذي ( أبو حنين ) وإثراء للموضوع أليك أخي الحل بالمعادلات ترحيل حسب التشابه.rar ترحيل حسب التشابة 2.rar تم تعديل نوفمبر 1, 2012 بواسطه mahmoud-lee رابط هذا التعليق شارك More sharing options...
رجب جاويش قام بنشر نوفمبر 1, 2012 مشاركة قام بنشر نوفمبر 1, 2012 بعد اذن أخى الحبيب / أبو حنين وأخى الحبيب / محمود ولإثراء الموضوع هذا كود آخر Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "1" Then sh.Range("a2:a1000").ClearContents End If Next LR = Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Range("A1:A" & LR) x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If cl.Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Range("A1") = "حرف" & " " & cl Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("1").Select Application.ScreenUpdating = False End Sub Book25555.rar رابط هذا التعليق شارك More sharing options...
rami91 قام بنشر نوفمبر 1, 2012 الكاتب مشاركة قام بنشر نوفمبر 1, 2012 أخي رجب جاويش الكود تمام ,ولكن لي رجاء أخير ,هل يمكن أن يشمل النسخ الصف كله .ويشمل العمود كله وليس عدد محدد كما في المرفق . بعد تعديل الطلب.zip رابط هذا التعليق شارك More sharing options...
رجب جاويش قام بنشر نوفمبر 1, 2012 مشاركة قام بنشر نوفمبر 1, 2012 أخى الفاضل فى السطر التالى cl.Resize(1, 2).Copy الرقم 2 هو عدد الخلايا التى تريد نسخها من الصف يمكنك تغيير الرقم كما تشاء Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "1" Then sh.Range("a1:iv1000").ClearContents End If Next LR = Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Range("A1:A" & LR) x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If cl.Resize(1, 2).Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Range("A1") = "حرف" & " " & cl Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("1").Select Application.ScreenUpdating = False End Sub 111بعد تعديل الطلب.rar رابط هذا التعليق شارك More sharing options...
rami91 قام بنشر نوفمبر 1, 2012 الكاتب مشاركة قام بنشر نوفمبر 1, 2012 شكراً جزيلاً أخي رجب جاويش وفرة علي الكثير من الوقت نفع الله بك . رابط هذا التعليق شارك More sharing options...
زيكو500 قام بنشر نوفمبر 2, 2012 مشاركة قام بنشر نوفمبر 2, 2012 السلام عليكم شكرا كثيرا لجهودكم أرجو التعديل علي نفس الملف و الكود و لكن نقل أعمدة متفرقة مثال العمود الأول و الثاني و الخامس و السابع كمثال أرجو الرد في أقرب فرصة شكرا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.