Option Explicit
Sub DeleteTextBoxes()
Dim L, T, W, H
L = 980: T = 10: W = 210: H = 66
If ActiveSheet.Shapes.Count > 0 Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
End If
'+++++++++++++++++++++++++++
ActiveSheet.Buttons.Add(L, T, W, H).Select
With Selection
.OnAction = "SLASHH_Total"
.Characters.Text = "Run"
With .Characters(1, 3).Font
.Size = 36
.ColorIndex = 3
.Bold = True
End With
End With
End Sub
'+++++++++++++++++++++++++++
Sub DrawSlash(headerRange As Range, DataRange As Range)
Dim shp As Shape
Dim c As Range
Const d As Integer = 15
For Each c In headerRange
If Application. _
CountA(DataRange.Columns(c.Column - DataRange.Column + 1)) > 0 Then
With ActiveSheet.Shapes _
.AddLine(c.Left + d, c.Top + d, _
c.Left + c.Width - d, c.Top + c.Height - d).Line
.ForeColor.RGB = RGB(255, 0, 0)
.Weight = 4.55
End With
End If
Next c
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub SLASHH_Total()
Dim ws As Worksheet
Dim oRng As Range
Dim m As Long
Dim i As Long
DeleteTextBoxes
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("sheet_mostgad")
m = ws.Cells(Rows.Count, "C").End(xlUp).Row + 3
For i = 5 To m Step 4
DrawSlash ws.Range("AY" & i & ":AY" & i), _
ws.Range("AY" & i + 1 & ":AY" & i + 2)
Next i
If Not oRng Is Nothing Then _
oRng.Interior.Color = RGB(208, 206, 206)
Application.ScreenUpdating = True
End Sub
[2]
وضع الشرطه المائله بشرط
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
