دمج كودين مع بعض

[أبو قاسم]

الكود الاول 

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Dim R As Integer

If Not Intersect(Target.Cells(1, 1), Union(Range("B3:B5000"), Range("o3:o5000"))) Is Nothing Then
    R = Target.Row
    If Cells(R, "B").Value <> "" Then
        Cells(R, "A").Value = R + 4948
        
       
        Cells(R, "C").Value = WorksheetFunction.VLookup(Cells(R, "B"), [TUNNEL3], 2, 0)
        
    Else
        Union(Cells(R, "0"), Cells(R, "0")).ClearContents
    End If
          End If
               If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Row > 1 And Target.Column = 9 Then
        With Target.Offset(, 1)
            .Formula = "=MOD(" & (Target - Target.Offset(, -1)) & ",1)": .Value = .Value
        End With
End If
     If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Row > 1 And Target.Column = 12 Then
        With Target.Offset(, 1)
            .Formula = "=MOD(" & (Target - Target.Offset(, -4)) & ",1)": .Value = .Value
        End With
    End If
If Target.Cells.Count > 1 Then Exit Sub

        If Not Intersect(Target, Range("E3:E5000")) Is Nothing Then

            With Target(1, 2)

                .Value = Date

               Application.ScreenUpdating = True
            End With
           End If

On Error GoTo 0
End Sub

الكود الثاني

Sub Circles()
Dim c As Range
Dim MyRng As Range
Set MyRng = Range("j3:j500")
Call RemoveCircles
      For Each c In MyRng
       If c.Value < Cells(1, 2) Then
         Set v = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height)
           v.Fill.Visible = msoFalse
           v.Line.ForeColor.SchemeColor = 10
           v.Line.Weight = 1.25
         End If
      Next
End Sub

[الصـقر]

اخى الفاضل

ممكن بعد اذن حضرتك ترفق الملف اللى فيه الكود

ياريت تراجع التوجيهات للاعضاء

http://www.officena.net/ib/topic/63020-توجيهات-للأعضاء-لمعرفة-كيفية-التعامل-مع-المنتدى-بشكل-أفضل/?do=findComment&comment=408853

 

تقبل تحياتى

تم تعديل نوفمبر 18, 2015 بواسطه الصـقر