المساعدة فى نسخ وترحيل بشرط

[me7534650]

نسخ الصفوف وتلرحيل الى شيت جديد ذات الخلية الاولى المتشابه

NEW.xlsx

[ابراهيم الحداد]

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

استخدم هذا الكود

Sub AdSh_Data()
Dim ws As Worksheet, C As Range
Dim x As Byte, WF As Object
Dim LR As Long, Sh As Worksheet
Set ws = Sheets("ورقة1")
Set WF = Application.WorksheetFunction
LR = ws.Range("A" & Rows.Count).End(3).Row
For Each C In ws.Range("A1:A" & LR)
x = WF.CountIf(ws.Range("A1:A" & C.Row), C)
On Error Resume Next
If x = 1 Then
If Len(Sheets(C).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value
End If
End If
Next
88:
For Each Sh In ThisWorkbook.Worksheets
For Each C In ws.Range("A1:A" & LR)
If Sh.Name = C.Value Then
p = p + 1
Sh.Range("A" & p).Resize(, 8) = ws.Cells(C.Row, 1).Resize(, 8).Value
End If
Next
p = 0
Next
End Sub