البحث في الموقع
Showing results for tags 'دمج اكواد'.
تم العثور علي 1 نتيجه
-
الكود الاول 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
