السلام عليكم ورحمة الله وبركاته
الأخـوة الكرام
برجاء المساعدة في ظبط جزئية الاحصاء في كود ترحيل الاقامة حسب الصلاحية
حيث أن لايقوم بعد الاقامات المرحلة حسب الصلاحية مضبوط
الكود
Sub TARHEEL()
Dim R As Integer, A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer
Sheets("الأقامات السارية").Range("A5:K1000").ClearContents
Sheets("القامات المنتهية").Range("A5:K1000").ClearContents
A = 5: B = 5: C = 5: D = 5: E = 5: F = 5: G = 5: H = 5: I = 5: j = 5: K = 5
Application.ScreenUpdating = False
For R = 5 To 1000
'''''''''''''''''''''''''''''''''''''''''''''''''''
If Cells(R, 6) = " الإقامة سارية" Then
Range("A" & R).Resize(1, 11).Copy
Sheets("الأقامات السارية").Range("A" & A).PasteSpecial xlPasteValues
Application.CutCopyMode = False
A = A + 1
End If
''''''''''''''''''''''''''
If Cells(R, 6) = "الإقامة منتهية" Then
Range("A" & R).Resize(1, 11).Copy
Sheets("الأقامات المنتهية").Range("A" & B).PasteSpecial xlPasteValues
Application.CutCopyMode = False
B = B + 1
End If
Next
MsgBox ("الحمد لله تم ترحيل الأقامات حسب الصلاحية ")
For K = 1 To 2
Y = Sheets(K).[B3000].End(xlUp).Row - 4
mssg = mssg & Chr(10) & Format(Y, "00") & " إقامـة : " & K
Next K
MsgBox (" تـم ترحيل عدد" & mssg)
For j = 1 To 2
Sheets(j).[B5] = 1
rrw = Sheets(j).[B3000].End(xlUp).Row
For Each CC In Sheets(j).Range("B6:B" & rrw)
CC.Value = CC.Offset(-1, 0) + 1
Next CC
Next j
Sheets("DATA").Select
Range("B5").Select
Application.ScreenUpdating = True
End Sub
بالمرفقات الملف
Validity.rar