ترحيل حسب التشابه لورق جديد

[rami91]

السلام عليكم :

المطلوب في المرفقات وشكرا لكم .

Book2.zip

[أبو حنــــين]

استعمل هذا الماكرو

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

[جمال عبد السميع]

بعد إذن أستاذي ( أبو حنين ) وإثراء للموضوع أليك أخي الحل بالمعادلات

ترحيل حسب التشابه.rar

ترحيل حسب التشابة 2.rar

تم تعديل نوفمبر 1, 2012 بواسطه mahmoud-lee

[رجب جاويش]

بعد اذن أخى الحبيب / أبو حنين

وأخى الحبيب / محمود

ولإثراء الموضوع

هذا كود آخر

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

[rami91]

أخي رجب جاويش الكود تمام ,ولكن لي رجاء أخير ,هل يمكن أن يشمل النسخ الصف كله .ويشمل العمود كله وليس عدد محدد

كما في المرفق .

بعد تعديل الطلب.zip

[رجب جاويش]

أخى الفاضل

فى السطر التالى

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

[rami91]

شكراً جزيلاً أخي رجب جاويش وفرة علي الكثير من الوقت نفع الله بك .

[زيكو500]

السلام عليكم

شكرا كثيرا لجهودكم

أرجو التعديل علي نفس الملف و الكود و لكن نقل أعمدة متفرقة

مثال العمود الأول و الثاني و الخامس و السابع كمثال

أرجو الرد في أقرب فرصة

شكرا