كود جمع مع ترحيل بيانات اعمده بشرط معطي

[ابو حمادة]

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

اساتذتي الافاضل

كل عام وانتم  بخير

ملف مرفق للعمل عليه وجاكم الله كل خير

Book1.rar

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

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

انسخ هذا الكود والصقه فى موديول جديد

واربطه بالزر الموجود

Sub EditData()
Const x = 155
Dim cel As Range
For Each cel In Range("A4:A10")
If cel.Value = x Then
cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2)
cel.Offset(0, 2) = cel.Offset(0, 3)
cel.Offset(0, 3) = cel.Offset(0, 4)
cel.Offset(0, 4) = cel.Offset(0, 5)
cel.Offset(0, 5) = cel.Offset(0, 6)
End If
Next
End Sub

 

[ابو حمادة]

3 ساعات مضت, زيزو العجوز said:

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

انسخ هذا الكود والصقه فى موديول جديد

واربطه بالزر الموجود

Sub EditData()
Const x = 155
Dim cel As Range
For Each cel In Range("A4:A10")
If cel.Value = x Then
cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2)
cel.Offset(0, 2) = cel.Offset(0, 3)
cel.Offset(0, 3) = cel.Offset(0, 4)
cel.Offset(0, 4) = cel.Offset(0, 5)
cel.Offset(0, 5) = cel.Offset(0, 6)
End If
Next
End Sub

 

شكرا ليك استاذي الفاضل وليا رجاء لو تكرمت ان يكون الكو لاخر صف  به بيانات في العمود A

لو امكن

 

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

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

استبدل الكود السابق بهذا الكود

Sub EditData()
Const x = 155
Dim cel As Range
For Each cel In Range("A4:A" & Range("A" & Rows.Count).End(xlUp).Row)
If cel.Value = x Then
cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2)
cel.Offset(0, 2) = cel.Offset(0, 3)
cel.Offset(0, 3) = cel.Offset(0, 4)
cel.Offset(0, 4) = cel.Offset(0, 5)
cel.Offset(0, 5) = cel.Offset(0, 6)
End If
Next
End Sub

 

[ابو حمادة]

7 ساعات مضت, زيزو العجوز said:

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

استبدل الكود السابق بهذا الكود

Sub EditData()
Const x = 155
Dim cel As Range
For Each cel In Range("A4:A" & Range("A" & Rows.Count).End(xlUp).Row)
If cel.Value = x Then
cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2)
cel.Offset(0, 2) = cel.Offset(0, 3)
cel.Offset(0, 3) = cel.Offset(0, 4)
cel.Offset(0, 4) = cel.Offset(0, 5)
cel.Offset(0, 5) = cel.Offset(0, 6)
End If
Next
End Sub

 

الف الف الف مليون شكر استاذي  الغالي 

بجد عاجز عن شكرى لحضرتتك 

ولى رجاء واتمنى مكونش تقلت عليك  باقي هذا الشرط 

 

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

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

استبدل الكود السابق بهذا الكود

Sub EditData()
Const x = 155
Dim cel As Range, z As Single
For Each cel In ورقة1.Range("A4:A" & ورقة1.Range("A" & Rows.Count).End(xlUp).Row)
If cel.Value = x Then
cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2)
cel.Offset(0, 2) = cel.Offset(0, 3)
cel.Offset(0, 3) = cel.Offset(0, 4)
cel.Offset(0, 4) = cel.Offset(0, 5)
cel.Offset(0, 5) = cel.Offset(0, 6)
z = WorksheetFunction.Round(cel.Offset(0, 1) * Range("G3"), 2)
cel.Offset(0, 6) = z
End If
Next
End Sub

 

[ابو حمادة]

6 ساعات مضت, زيزو العجوز said:

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

استبدل الكود السابق بهذا الكود

Sub EditData()
Const x = 155
Dim cel As Range, z As Single
For Each cel In ورقة1.Range("A4:A" & ورقة1.Range("A" & Rows.Count).End(xlUp).Row)
If cel.Value = x Then
cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2)
cel.Offset(0, 2) = cel.Offset(0, 3)
cel.Offset(0, 3) = cel.Offset(0, 4)
cel.Offset(0, 4) = cel.Offset(0, 5)
cel.Offset(0, 5) = cel.Offset(0, 6)
z = WorksheetFunction.Round(cel.Offset(0, 1) * Range("G3"), 2)
cel.Offset(0, 6) = z
End If
Next
End Sub

 

[ابو حمادة]

استاذي الغالي استاذ     زيزو العجوز

لو سمحت ممكن يتم تعيل  هذا الكود ليتناسب مع الشيت الاصلي لاختلاف الاعمده لانى حولت اغير ارقام الاعمده للاسف مقدرتش

هذا الشيت الاصلي

Book1.rar

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

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

استخدم الكود التالى

Sub EditData()
Const x = 155
Dim cel As Range, z As Single
For Each cel In ورقة1.Range("F4:F" & ورقة1.Range("F" & Rows.Count).End(xlUp).Row)
If cel.Value = x Then
cel.Offset(0, 22) = cel.Offset(0, 23) + cel.Offset(0, 24)
cel.Offset(0, 24) = cel.Offset(0, 25)
cel.Offset(0, 25) = cel.Offset(0, 26)
cel.Offset(0, 26) = cel.Offset(0, 27)
cel.Offset(0, 27) = cel.Offset(0, 28)
z = WorksheetFunction.Round(cel.Offset(0, 27) * Range("AG3"), 2)
cel.Offset(0, 33) = z
End If
Next
End Sub