السلام عليكم
اخي العزيز
ساحاول الشرح قدر استطاعتي مع العلم ان الكود يعمل بكفاءة دون اي مشاكل
و هذا هو الكود مرفق بالشرح
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim response
r = 6 'تحديد العمود
For n = 2 To 1000 ' الصفوف من الثاني الي ال 1000
If Target.Cells <> Cells(n, r) Then Exit Sub ' اذا كان التعامل خارج نطاق الصفوف الحدده و العمود المحدد يتوقف الكود
df = Target.Row 'اعطاء مسمي لصف الخلية التي نقف عليها و نكتب بيانها
If Cells(df, 3) = "الصندوق" Then 'شرط اذا كان الف الذي نكتب بيانه في العمود الثالث منه المكتوب به الصندوق عندئذ
With Sheets("الصندوق").Columns(1).Rows(300).End(xlUp) ' يتم الاتجاه الي صفحة الصندوق العمود الاول تحت اخر خليه بها قيمة حتي الصف ال300
.Offset(1, 0) = Cells(df, 1) 'العمود الاول ياخذ قيمة العمود الاول لصف الخلية التي يكتب بيانها
.Offset(1, 1) = Cells(df, 2) 'العمود الاول ياخذ قيمة العمود الثاني لصف الخلية التي يكتب بيانها
.Offset(1, 2) = Cells(df, 4) 'العمود الاول ياخذ قيمة العمود الرابع لصف الخلية التي يكتب بيانها
.Offset(1, 3) = Cells(df, 5) 'العمود الاول ياخذ قيمة العمود الخامس لصف الخلية التي يكتب بيانها
.Offset(1, 4) = Cells(df, 6) 'العمود الاول ياخذ قيمة العمود السادس لصف الخلية التي يكتب بيانها
End With
End
Else ' غير ذلك
If Cells(df, 3) = "المبيعات" Then ' نفس الشئ اذا كانت الخليه المكتوب بها كلمة المبيعات
With Sheets("المبيعات").Columns(1).Rows(300).End(xlUp)
.Offset(1, 0) = Cells(df, 1)
.Offset(1, 1) = Cells(df, 2)
.Offset(1, 2) = Cells(df, 4)
.Offset(1, 3) = Cells(df, 5)
.Offset(1, 4) = Cells(df, 6)
End With
End If
End
End If
Next
End Sub
جرب مرة ثانية و اخبرني النتيجة
ارسل لك ملفا اخر مضاف له شرط عدم تكرار ترحيل القيد
تحياتي
______.rar