اختصار كود

**ابو حمادة** · مايو 31, 2018

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

كل عام وانتم بخير بمناسبه حلول شهر رمضان المعظم اعاده الله علينا وعليكم وعلى امة المسلمين باليمن والخير والبركات

استفسار

1- لدى ملف به عدد اعمده كثيره جدا وصفوف تتخطي 10 الاف صف

الكود يعمل كما اريد ولكن الكود طويل جدا وبياخد وقت فى تنفيذ الكود

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

هل من الممكن اختصار الكود المرفق لكي ينفذ ما اريد بسرعه افضل من هذا

Sub Click3() 
On Error GoTo 1
    
    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim N, C2 As Range
      '   On Error Resume Next
For Each N In ws.Range("H6:H" & ws.Range("B" & Rows.Count).End(xlUp).Row)
  
  If N.Value = "محمود" Or N.Value = "احمد" Then
           Application.ScreenUpdating = False

    N.Offset(0, 111) = "" 
    N.Offset(0, 112) = "" 
    N.Offset(0, 113) = "" 
    N.Offset(0, 114) = "" 
    N.Offset(0, 115) = "" 
    N.Offset(0, 116) = "" 

'    N.Offset(0, 117) = "" 
    N.Offset(0, 118) = Format(Round(N.Offset(0, 171) + N.Offset(0, 172) + N.Offset(0, 173) + N.Offset(0, 174), 2)) 
    
    N.Offset(0, 119) = "" ''
    N.Offset(0, 120) = "" ''
    N.Offset(0, 121) = "" ''
    N.Offset(0, 122) = "" ''
    N.Offset(0, 123) = "" ''
    N.Offset(0, 124) = "" ''
    N.Offset(0, 125) = "" ''
    N.Offset(0, 126) = "" ''
    N.Offset(0, 127) = "" ''
    N.Offset(0, 128) = "" ''
    N.Offset(0, 129) = "" ''
    N.Offset(0, 130) = "" ''
    N.Offset(0, 131) = "" ''
    N.Offset(0, 132) = "" ''
    N.Offset(0, 133) = "" ''
    N.Offset(0, 134) = "" ''
    N.Offset(0, 135) = "" ''
    N.Offset(0, 136) = "" ''
    N.Offset(0, 137) = "" ''
    N.Offset(0, 138) = "" ''
    N.Offset(0, 139) = "" ''
    N.Offset(0, 140) = "" ''
    N.Offset(0, 141) = "" ''
    N.Offset(0, 142) = "" ''
    N.Offset(0, 143) = "" ''
    N.Offset(0, 144) = "" ''
    N.Offset(0, 145) = "" ''
    N.Offset(0, 146) = "" ''
    N.Offset(0, 147) = "" ''
    N.Offset(0, 148) = "" ''
    N.Offset(0, 149) = "" ''
    N.Offset(0, 150) = "" ''
    N.Offset(0, 151) = "" ''
    N.Offset(0, 152) = "" ''
    N.Offset(0, 153) = "" ''
    N.Offset(0, 154) = "" ''
    N.Offset(0, 155) = "" ''
    N.Offset(0, 156) = "" ''
    N.Offset(0, 157) = "" ''
    N.Offset(0, 158) = "" ''
    N.Offset(0, 159) = "" ''
    N.Offset(0, 160) = "" ''
    N.Offset(0, 161) = "" ''
    N.Offset(0, 162) = "" ''
    N.Offset(0, 163) = "" ''


'    N.Offset(0, 164) = "" 
    N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), 2))  
    
    N.Offset(0, 166) = "" ''
    N.Offset(0, 167) = "" ''
    N.Offset(0, 168) = "" ''
    N.Offset(0, 169) = "" ''

    
    N.Offset(0, 175) = "" ''
    N.Offset(0, 177) = "" ''
    N.Offset(0, 178) = "" ''
    N.Offset(0, 179) = "" ''
    
'    N.Offset(0, 180) = "" ''
'    N.Offset(0, 181) = "" ''
    N.Offset(0, 182) = "" ''
'    N.Offset(0, 183) = "" ''
    N.Offset(0, 184) = "" ''
    N.Offset(0, 185) = "" ''
    N.Offset(0, 186) = "" ''
    N.Offset(0, 187) = "" ''
    N.Offset(0, 188) = "" ''
    N.Offset(0, 189) = "" ''
    
    N.Offset(0, 190) = "" ''
    N.Offset(0, 191) = "" ''
    N.Offset(0, 192) = "" ''
    N.Offset(0, 193) = "" ''
    N.Offset(0, 194) = "" ''
    N.Offset(0, 195) = "" ''
    N.Offset(0, 196) = "" ''
    N.Offset(0, 197) = "" ''
    N.Offset(0, 198) = "" ''
    N.Offset(0, 199) = "" ''
    
    N.Offset(0, 200) = "" ''
    N.Offset(0, 201) = "" ''
    N.Offset(0, 202) = "" ''
    N.Offset(0, 203) = "" ''
    N.Offset(0, 204) = "" ''
    N.Offset(0, 205) = "" ''
    N.Offset(0, 206) = "" ''
    N.Offset(0, 207) = "" ''
    N.Offset(0, 208) = "" ''
    N.Offset(0, 209) = "" ''
    
    N.Offset(0, 210) = "" ''
    N.Offset(0, 211) = "" ''
    N.Offset(0, 212) = "" ''
    N.Offset(0, 213) = "" ''
    N.Offset(0, 214) = "" ''
    N.Offset(0, 215) = "" ''
    N.Offset(0, 216) = "" ''
    N.Offset(0, 217) = "" ''
    N.Offset(0, 218) = "" ''
    N.Offset(0, 219) = "" ''
    
    N.Offset(0, 220) = "" ''
    N.Offset(0, 221) = "" ''
    N.Offset(0, 222) = "" ''
    N.Offset(0, 223) = "" ''
    N.Offset(0, 224) = "" ''
    N.Offset(0, 225) = "" ''
    N.Offset(0, 226) = "" ''
    N.Offset(0, 227) = "" ''
    N.Offset(0, 228) = "" ''
    N.Offset(0, 229) = "" ''
    
    N.Offset(0, 230) = "" ''
    N.Offset(0, 231) = "" ''
    N.Offset(0, 232) = "" ''
    N.Offset(0, 233) = "" ''
    N.Offset(0, 234) = "" ''
    N.Offset(0, 235) = "" ''
    N.Offset(0, 236) = "" ''
    N.Offset(0, 237) = "" ''
    N.Offset(0, 238) = "" ''
    N.Offset(0, 239) = "" ''

    N.Offset(0, 240) = "" ''
    N.Offset(0, 241) = "" ''
    N.Offset(0, 242) = "" ''
    N.Offset(0, 243) = "" ''
    N.Offset(0, 244) = "" ''
    N.Offset(0, 245) = "" ''
    N.Offset(0, 246) = "" ''
    N.Offset(0, 247) = "" ''
    N.Offset(0, 248) = "" ''
    N.Offset(0, 249) = "" ''
    
    N.Offset(0, 250) = "" ''
    N.Offset(0, 251) = "" ''
    N.Offset(0, 252) = "" ''
    N.Offset(0, 253) = "" ''
    N.Offset(0, 254) = "" ''
    N.Offset(0, 255) = "" ''
    N.Offset(0, 256) = "" ''

End If
Next
      Application.ScreenUpdating = True

1 End Sub

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

**احمد بدره** · مايو 31, 2018

قم بنقل هذا الكود

           Application.ScreenUpdating = False

في صدر الماكرو بعد

On Error GoTo 1

فأعتقد يكون أسرع

**سليم حاصبيا** · يونيو 1, 2018

اختصار الكود

Option Explicit

Sub Click3()

 Application.ScreenUpdating = False

On Error GoTo 1
    
    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim N, C2 As Range
    Dim I%
      '   On Error Resume Next
For Each N In ws.Range("H6:H" & ws.Range("B" & Rows.Count).End(xlUp).Row)
  
  If N.Value = "محمود" Or N.Value = "احمد" Then
     For I = 111 To 256
      If I = 117 Or I = 164 Or I = 183 Then I = I + 1
      If I = 180 Then I = I + 2
       N.Offset(0, I) = vbNullString
   Next
   End If
      N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), 2))
 Application.ScreenUpdating = True
   
1 End Sub

**ابو حمادة** · يونيو 2, 2018

في ١‏/٦‏/٢٠١٨ at 05:16, سليم حاصبيا said:

اختصار الكود


Option Explicit

Sub Click3()

 Application.ScreenUpdating = False

On Error GoTo 1
    
    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim N, C2 As Range
    Dim I%
      '   On Error Resume Next
For Each N In ws.Range("H6:H" & ws.Range("B" & Rows.Count).End(xlUp).Row)
  
  If N.Value = "محمود" Or N.Value = "احمد" Then
     For I = 111 To 256
      If I = 117 Or I = 164 Or I = 183 Then I = I + 1
      If I = 180 Then I = I + 2
       N.Offset(0, I) = vbNullString
   Next
   End If
      N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), 2))
 Application.ScreenUpdating = True
   
1 End Sub

شكرا لاهتمامك استاذي الفاضل

انا جربت الكود بتظهر رسالة خطأء وبيتم تحديد اخر سطر فى الكود ( 1 End Sub )

كما واضح فى الصورة

Capture.PNG.ae714d2fde34c7a588ee4bc512c92654.PNG

**احمد بدره** · يونيو 2, 2018

بعد إذن الأستاذ سليم

اكتب

ليصبح الكود

Sub Click3()

Application.ScreenUpdating = False

On Error GoTo 1

    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim N, C2 As Range
    Dim I%
      '   On Error Resume Next
For Each N In ws.Range("H6:H" & ws.Range("B" & Rows.Count).End(xlUp).Row)

If N.Value = "محمود" Or N.Value = "احمد" Then
     For I = 111 To 256
      If I = 117 Or I = 164 Or I = 183 Then I = I + 1
      If I = 180 Then I = I + 2
       N.Offset(0, I) = vbNullString
   Next
   End If

      N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), 2))
Application.ScreenUpdating = True
Next
1 End Sub

**سليم حاصبيا** · يونيو 2, 2018

الكود فقظ انا وضعته و لم أجربه

لكن في رأي ان Next يجب ان توضع بعد End If وليس قبل End sub

حتى لا تتكرر عبارة N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), عند كل حلقة تكرارية

ليبدو الكود بهذا الشكل

Option Explicit

Sub Click3()

 Application.ScreenUpdating = False

On Error GoTo 1
    
    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim N, C2 As Range
    Dim I%
      '   On Error Resume Next
For Each N In ws.Range("H6:H" & ws.Range("B" & Rows.Count).End(xlUp).Row)
  
  If N.Value = "محمود" Or N.Value = "احمد" Then
     For I = 111 To 256
      If I = 117 Or I = 164 Or I = 183 Then I = I + 1
      If I = 180 Then I = I + 2
       N.Offset(0, I) = vbNullString
      End If
Next
      N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), 2))
1:
 Application.ScreenUpdating = True
   
 End Sub

**ابو حمادة** · يونيو 2, 2018

شكر لكم اساتذتى الافاضل ولكن هناك عدة مشاكل الكود اشتغل لما اضفط ( Next ) قبل End sub

ولكن تقيل جدا جدا فى التنفيذ والنتيجه خطأ

وايضا هذا السطر بالكود الاول

    N.Offset(0, 118) = Format(Round(N.Offset(0, 171) + N.Offset(0, 172) + N.Offset(0, 173) + N.Offset(0, 174), 2))

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

علما انا هذا السطر يجب تنفيذه قبل مسح باقي البيانات

فلذلك النتيجه خطأ

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

ولكم منى جزيل الشكر

shreif mohamed · يونيو 3, 2018

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

Sub Click3()
On Error GoTo 1
    
    Dim ws As Worksheet: Set ws = Sheets("add")
    Dim N, C2 As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
      '   On Error Resume Next
For Each N In ws.Range("H6:H" & ws.Range("B" & Rows.Count).End(xlUp).Row)
    If N.Value = "محمود" Or N.Value = "احمد" Then
    Range(N.Offset(0, 111), N.Offset(0, 116)).ClearContents
'   N.Offset(0, 117) = ""
    N.Offset(0, 118) = Format(Round(N.Offset(0, 171) + N.Offset(0, 172) + N.Offset(0, 173) + N.Offset(0, 174), 2))
    Range(N.Offset(0, 119), N.Offset(0, 163)).ClearContents   
'   N.Offset(0, 164) = ""
    N.Offset(0, 165) = Format(Round(N.Offset(0, 180) + N.Offset(0, 181), 2))
    Range(N.Offset(0, 166), N.Offset(0, 169)).ClearContents
    Range(N.Offset(0, 175), N.Offset(0, 179)).ClearContents     
'   N.Offset(0, 180) = "" ''
'   N.Offset(0, 181) = "" ''
    N.Offset(0, 182).ClearContents
'   N.Offset(0, 183) = "" ''
    Range(N.Offset(0, 184), N.Offset(0, 256)).ClearContents
End If
Next
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
1 End Sub

تم تعديل يونيو 3, 2018 بواسطه shreif mohamed

تسجيل الدخول

اختصار كود

الردود الموصى بها

ابو حمادة

احمد بدره

سليم حاصبيا

ابو حمادة

احمد بدره

سليم حاصبيا

ابو حمادة

shreif mohamed

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information