احتاج مساعدة استاذ سليم فى هذا الكود الذى اهدانى اياه لكى لا يتم استدعاء الارقام السالبة

[yara ahmed]

احتاج مساعدة  اخى استاذ سليم الغالى لقلبى هذا الكود من ابداعاته

احتاج تعديلة بحيث لا يستدعى الارقام السالبة 

مع حبى وشكرى

 

yara_salim_NEW.xlsm

[سليم حاصبيا]

تم معالجة الأمر

 

yara_salim_Only_positive.xlsm

[yara ahmed]

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

كأن السطر مش موجود فهمنى اخى واشكرك من قلبى اخى الرائع سليم الغالى

حبى وشكرى

 

[سليم حاصبيا]

الآن اصبح الموضوع اكثر تعقيداً

كان من المفروض طرح هذا الموضوع مرة واحدة

لاني اشتغلت على ما طلبته حسب سؤالك      "حيث لا يستدعى الارقام السالبة"

[yara ahmed]

معلش سامحنى انا افتكرت انى كده وصلت المطلوب معلش

ربنا ما يحرمنى منك

[سليم حاصبيا]

جربي هذا الكود

Option Explicit
Sub Salim_Code_Only_Positive()
      Rem    <<<< Created By Salim Hasbaya On 27/7/2020 >>>>
 Dim a()
 Dim Sh As Worksheet, D As Worksheet
 Dim m%, k%, x%, t%
 Dim Rg As Range, XX%, cnt%
 Dim dat1 As Date, dat2 As Date
 Dim Itm, cel As Range
    Application.ScreenUpdating = False
k = 1
 Set D = ThisWorkbook.Worksheets("DataReport")
 D.Range("A2:k" & Rows.Count).Clear
      If Not IsDate(D.Range("M2")) Or _
          Not IsDate(D.Range("M2")) Then
           MsgBox "Wrong dates in cells M1 Or N2"
          GoTo Leave_me_Olone
      End If
 dat1 = Application.Min(D.Range("M2:N2"))
 dat2 = Application.Max(D.Range("M2:N2"))

  For Each Sh In ThisWorkbook.Worksheets
   If Sh.Name <> D.Name And Sh.Tab.Color = 5287936 Then
    ReDim Preserve a(1 To k): a(k) = Sh.Name: k = k + 1
 End If
 Next
  m = 2: k = 2
 For Each Itm In a
  Set Sh = Sheets(Itm)
   x = Sh.Cells(Rows.Count, 1).End(3).Row
   Sh.Cells(6, 1).Resize(x - 5, 10).Interior.ColorIndex = xlNone
    For t = 6 To x
      If Sh.Cells(t, 1) >= dat1 And Sh.Cells(t, 1) <= dat2 Then
      
      For XX = 3 To 10
       If Sh.Cells(t, XX) < 0 Then
       cnt = cnt + 1
       Exit For
       End If
      Next XX
      
      If cnt = 0 Then
        If Rg Is Nothing Then
         Set Rg = Sh.Cells(t, 1).Resize(, 10)
        Else
         Set Rg = Union(Rg, Sh.Cells(t, 1).Resize(, 10))
        End If
      End If
    End If
    cnt = 0
    Next t
   If Not Rg Is Nothing Then
       D.Cells(m, 1) = Rg.Parent.Name
       Rg.Copy D.Cells(m, 2)
       Rg.Interior.ColorIndex = 27
      m = D.Cells(Rows.Count, 2).End(3).Row + 3
      

      
      D.Cells(m - 2, 1) = "Totat"
      D.Cells(m - 2, 4).Resize(, 8).Formula = _
      "=SUM(D" & k & ":D" & m - 3 & ")"
      D.Cells(m - 1, 3).Resize(, 10).Value = _
      D.Cells(1, "C").Resize(, 10).Value
      D.Cells(m - 2, 1).Resize(, 11).Interior.ColorIndex = 35
      D.Cells(m - 1, 1).Resize(, 11).Interior.ColorIndex = 40
      k = m
   End If
   Set Rg = Nothing
 Next Itm
  D.Cells(m, 1) = "Sum off All"
  D.Cells(m, 4).Resize(, 8).Formula = _
  "=SUM(D2:D" & m - 1 & ")/2"
  D.Cells(m, 1).Resize(, 11).Interior.ColorIndex = 39
  D.Cells(m - 1, 1).EntireRow.Delete
 Set Rg = D.Range("A2").CurrentRegion
  If Rg.Rows.Count > 1 Then
   Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1)
    With Rg
     .Borders.LineStyle = 1
     .InsertIndent 1
     .Font.Bold = True
     .Font.Size = 14
     .Value = .Value
    End With
  End If
  
Leave_me_Olone:
  Set Sh = Nothing: Set D = Nothing
  Set Rg = Nothing: Erase a
  
  Application.ScreenUpdating = True

End Sub

الملف مرفق

 

yara_salim_Only_positive_special.xlsm

[yara ahmed]

تسلم لى ايدك وعينك يارب يحفظك ان شاء الله موفق دائما

كل حبى وشكرى من قلبى ربنا ما يحرمنى منك ابداااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااا