استبدل لكود الموجود بهذا المعدل
Sub trheel()
Dim cl As Range
On Error Resume Next
lr = [h10000].End(xlUp).Row
If lr < 5 Then lr = 5
For r = 5 To lr
If Cells(r, "H").Value.Value = "" Then
MsgBox "la cellule " & Cells(r, "H").Address & " est vide"
Exit Sub
End If
i = Cells(r, "H").Value
Range("B" & r & ":H" & r).Copy Sheets(i).Range("B" & Sheets(i).[b999].End(xlUp).Row + 1)
Next
Range("B5:H" & lr).ClearContents
End Sub
اضف سطر واحد الى الكود ليصبح هكذا
Sub trheel()
Dim cl As Range
On Error Resume Next
lr = [h10000].End(xlUp).Row
If lr < 5 Then lr = 5
For r = 5 To lr
i = Cells(r, "H").Value
Range("B" & r & ":H" & r).Copy Sheets(i).Range("B" & Sheets(i).[b999].End(xlUp).Row + 1)
Next
Range("B5:H" & lr).ClearContents
End Sub
تم معالجة الامر
اذا اردت ان يكون ذلك بالمعادلات يمكن ذلك من خلال هذه المعادلة والسحب يمبناً الى قدر ما تشاء من الاعمدة
اكتب المعادلة في اي مكان تريد ما عدا العامود الاول
=IF(INDIRECT("$a"&COLUMNS($A$1:A1))<>"",INDIRECT("$a"&COLUMNS($A$1:A1)),"")
تحويل الى صفوف.rar
اخي كريم لا تتسرع بقراراتك
انت وضعت المشاركة الساعة 10
قررت انه ليس هناك من استجابة الساعة الواحدة
تم اتخذت القرار بعد دقيقتين
متجاهلاً ان للاعضاء اعمالاً اخرى وليس هناك من شيء الا الرد على المساعدات
وانت تعلم ان هدف المنتدى ليس مادياً البحتة و كل عضو يقوم بواجباته حسب خبرته لوجه الله تعالى
لذلك ليس هناك من التزام للرد عند اي فرد من الاعضاء
بالاضافة ان سؤالك يجب ان يكون موجهاً الى قسم الاكسس و ليس الاكسل
على كل حال جرب هذا الملف و عسى ان يكون المطلوب
trim.rar
بعد السلام
اليك هذا الحل القوائم المنسدلة مطاطة تستجيب لاي تغيير فقط اذا كان اسم المادة غير مكرر
اضغط افضل اجابة اذا كان كذلك
استخراج القيم حسب التاريخ salim.rar
احي احمد انها تعمل على كل الاجهزة
فالجهاز الذي اعدادات الاكسل به على النقطة فاصلة يجب ان نضع نقطة فاصلة في اي معادلة
و كذلك الامر بالنسبة للفاصلة
يمكن التغيير من اعدادات الفاصلة الى النقطة فاصلة و بالعكس من داخل الـ Control Panel