غزيزي الغالي شكرا لمجهودك
ولكن يبدو انني لم استطيع ايصال المعلومة بالشكل المطلوب
انا اريد ان ترحل البيانات بدلاله الكود اي تذهب كل مجموعه من البيانات بكود متشابه الي صحفة مستلقة لانه يمكن ان تكون هناك اكواد جديد تستحدث
لقد وجد كود يعمل بصورة جيده كما اريد هل يمكن تطبيقه علي المثال الخاص بي ولك جزيل الشكر
----------------------------------------------------------------------------------------------------------------------------------------
Sub Excel4Us()
'www.Excel4us.com
'اول موقع عربي متخصص في الإكسيل
' مع تحيات اخوكم في الله : يحيى حسين
Application.ScreenUpdating = False
Dim i As Range, LR As Long, ws As Worksheet, wb As Workbook, C As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("sheet1").Range("d1:d" & LR).AdvancedFilter xlFilterCopy, copytorange:=Range("h1"), unique:=True
For Each C In Range("h2:h" & Range("h" & Rows.Count).End(xlUp).Row)
On Error GoTo 1
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value
Next C
1
For Each C In Sheets("sheet1").Range("h2:h" & Sheets("sheet1").Range("h" & Rows.Count).End(xlUp).Row)
Sheets("sheet1").Range("a1:d1").AutoFilter field:=4, Criteria1:=C.Value
Sheets("sheet1").Range("a1:d" & Sheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
For Each ws In ThisWorkbook.Worksheets
If ws.Name = C.Value Then
ws.Range("a1").PasteSpecial xlPasteColumnWidths
ws.Range("a1").PasteSpecial xlValue
ws.Range("a1").PasteSpecial xlPasteFormats
ws.DisplayRightToLeft = True
End If
Next ws
Sheets("sheet1").Range("a1:d1").AutoFilter
Application.CutCopyMode = False
Next C
Sheets("sheet1").Columns("h").Delete
Sheets("sheet1").Select
Application.ScreenUpdating = True
End Sub
