أستاذى الفاضل / الـعيدروس
كنت من قبل طلب سحب داتا فى شيت أخر وعملت به زر لمسح الداتا المنقولة أى إفراغها
وتفضل الأستاذ القدير الحبيب / ياسر خليل بهذا الكود
Sub ClearConstants()
Dim Rng As Range, Arr, I As Long, J As Long
With Sheets("Rank")
Set Rng = .Range("A9:S28")
Arr = Rng.Formula
End With
For I = 1 To UBound(Arr, 1)
If IsNumeric(Arr(I, 1)) Then
For J = 4 To 19 Step 3
Arr(I, J) = ""
Next J
End If
Next I
End Sub
وقمت بتنفيذه على الشيت الذى تفضلت حضرتك أستاذى القدير / العيدروس بعمل الكود له
ولم أفلح
فأين الخطأ ولسيادتكم خالص الشكر والتقدير
ولى طلب أخر هل يمكن إضافة رسالة ترحيب مثل ( تم بحمد الله ) فى الكود الأول
Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean)
Dim Shet As Worksheet
Dim Do_Ali
Dim Ar() As Variant
Dim iCnt&
Dim X, A
Set Shet = Sheets("Report")
Set Do_Ali = CreateObject("Scripting.Dictionary")
With Application
.ScreenUpdating = False
.EnableEvents = True
DoEvents
With Shet
Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
Ar = .Range("A2:F" & Lr).Value: A = Bl
For R = LBound(Ar, 1) To UBound(Ar, 1)
If Ar(R, 3) = A Then
If Not Bln Then X = IIf(Vl = 3, X + 1, IIf(Vl = 4, X + Ar(R, 6), X + 1))
If Do_Ali.exists(Ar(R, Ln)) Then
Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1
Else
Do_Ali.Add Ar(R, Ln), 1
End If
End If
Next
Ali = IIf(Vl = 1, Do_Ali.Count, X)
End With
.ScreenUpdating = True
.EnableEvents = False
End With
Erase Ar
Set Do_Ali = Nothing
Set Shet = Nothing
End Function
Sub Ali_Count()
Dim Sh As Worksheet
Dim R
Set Sh = Sheets("Rank")
For R = 10 To 28
With Sh
If .Cells(R, 2) <> "" Then
.Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False)
.Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False)
.Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True)
.Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True)
End If
End With
Next
Set Sh = Nothing
End Sub