خطأ فى الكود ( كود خاص بترحيل البيانات من شيت الي جميع شيتات الملف بناءا علي اسم الشيت ) {عنوان معدل}

[محمد عبد القادر]

السلام عليكم  ما الخطأ فى هذا الكود

و شكرا

بيانات اعدادى.rar

[رجب جاويش]

أخى الفاضل / محمد

هل تريد ترحيل البيانات إلى عدة صفحات اعتمادا  على إسم الصفحة الموجود فى العمود L

أرجو التوضيح

حتى يتم تعديل الكود كما تريد

[حمادة عمر]

السلام عليكم

الاخ الكريم / محمد عبد القادر

بارك الله فيك

وبعد اذن استاذي القدير /  رجب جاويش ... جزاه الله خيرا   (( اللي وحشنا كتييييييييييييير ))

الذي رأيت رده بعد ان قمت بالتعديل علي الكود ... وارجو ان يعجبه ويفي بغرضك

Sub tarheel()
Application.ScreenUpdating = False
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
For r = 2 To 1000
   If sh.Name = "sheet1" Then GoTo 2
      
   If Cells(r, 1).Value <> Empty Then
      If Cells(r, 12).Value = sh.Name Then
     Range(Cells(r, 1), Cells(r, 12)).Copy
     QQ = sh.Cells(1000, 1).End(xlUp).Row + 1
     sh.Range("A" & QQ).PasteSpecial xlPasteValues
     End If
     
     End If
  
     Next
     Next
     Application.DataEntryMode = False
     Application.ScreenUpdating = True
     
2 End Sub

تقبلوا خالص تحياتي

 

 

بيانات اعدادى1.rar

[رجب جاويش]

السلام عليكم

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

 

أخى الفاضل / محمد

ما رأيك فى هذا الكود بدلا من الكود الموجود بالملف

حيث يقوم الكود التالى بالترحيل حتى ولو لم تكن الصفحات التى سوف يرحيل إليها موجود فى البداية

كما أنه يرحل البيانات بنفس التنسيقات

وعمل مسلسل فى الصفحات التى سوف يرحل إليها

Sub ragab()
Dim cl As Range, sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If Not sh.Name = "Sheet1" Then
sh.Range("A2:L1000").ClearContents
End If
Next
LR = Cells(Rows.Count, 1).End(xlUp).Row
For Each cl In Range("L2:L" & 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
Sheets("sheet1").Range("A1:L1").Copy
Sheets(x).Range("A1").PasteSpecial xlPasteValues
Sheets(x).Range("A1").PasteSpecial xlPasteFormats
cl.Offset(0, -11).Resize(1, 12).Copy
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1) = Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1).Row - 1
Application.CutCopyMode = False
Next
MsgBox "تم الترحيل بنجاح الى صفحات منفصلة"
Sheets("sheet1").Select
Application.ScreenUpdating = False
End Sub

[محمود_الشريف]

أخى فى الله

استاذى القدير // رجب جاويش

بارك الله فيكم وزادكم الله من فضله ومن نعمه

 

 

والشكر موصول لإستاذى القدير // حماده عمر

 

وتقبلوا منى وافر الاحترام والتقدير

[رجب جاويش]

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

جزاك الله كل خير على هذه الكلمات الطيبة

[محمد يوسف محمد1]

الاساتذة الافاضل ابهرتونا بأعمالكم

ياريت شوية شرح

وشكرا

[حمادة عمر]

السلام عليكم

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

بارك الله فيك

كود جميل ومنظم وذكي واكثر من راائع

واظن انه يفي بالغرض وزيادة

وبالفعل وحشتنا ووحشتنا اعمالك واكوادك

زادك الله من فضله ومن علمه

تقبل خالص تحياتي

[محمد عبد القادر]

ما أجمل هذه الروح التى لا توجد إلا فى منتدى اكسل

جزاكم الله خيرا