جزاكم الله خيرا اخى الكريم الاستاذ سليم كود رائع
اثراء للموضوع اقدم لكم هذا الكود ان شاء الله ينال اعجابك ويفيد الاخوه الاعضاء

Sub Alsqr()
Dim lr As Long
Dim sh As String
Dim i As Worksheet
For Each i In Worksheets
lr = i.Cells(Rows.Count, 1).End(3).Row
sh = sh & i.Name & " " & "last row is" & " " & lr & Chr(13)
Next i
MsgBox sh, vbMsgBoxRight, "أكاديمية الصقر للتدريب"
End Sub

المشاركة الأصلية كتبت بواسطة: الصقر

جزاكم الله خيرا اخى الكريم الاستاذ سليم كود رائع
اثراء للموضوع اقدم لكم هذا الكود ان شاء الله ينال اعجابك ويفيد الاخوه الاعضاء

CODE

Sub Alsqr()
Dim lr As Long
Dim sh As String
Dim i As Worksheet
For Each i In Worksheets
lr = i.Cells(Rows.Count, 1).End(3).Row
sh = sh & i.Name & " " & "last row is" & " " & lr & Chr(13)
Next i
MsgBox sh, vbMsgBoxRight, "أكاديمية الصقر للتدريب"
End Sub

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

Sub Alsqr()
Dim lr As Long
Dim sh As String
Dim i As Worksheet
For Each i In Worksheets
lr = i.Cells.SpecialCells(xlLastCell).Row
sh = sh & i.Name & " " & "last row is" & " " & lr & Chr(13)
Next i
MsgBox sh, vbMsgBoxRight, "أكاديمية الصقر للتدريب"
End Sub

الكود يختلف عن الكود السابق فى استبدال هذا السطر

lr = i.Cells(Rows.Count, 1).End(3).Row<br />
<br />

بهذا السطر

lr = i.Cells.SpecialCells(xlLastCell).Row<br />
<br />

وهذا ايضا كود اخر اخى الكريم يعالج الكود السابق لان الكود السابق فى حال تنشيط اى خليه حتى ولو لم يتم كتابة اى محتوى بها سوف يقرءها اخر صف أما هذا يعالج القصور فى الكود السابق

Sub Alsqr()
Dim lr As Long
Dim sh As String
Dim i As Worksheet
For Each i In Worksheets
On Error Resume Next
lr = 0
lr = i.Cells.Find(What:="*", After:=Range("a1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sh = sh & i.Name & " " & "last row is" & " " & lr & Chr(13)
1
Next i
MsgBox sh, vbMsgBoxRight, "أكاديمية الصقر للتدريب"
End Sub

Sub Test_LastRow_UDF()
    MsgBox LastRow(ActiveSheet)
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
        LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    On Error GoTo 0
End Function

Sub Alsqr()
    For Each sht In Sheets
        Cells(a + 1, 1).Value = sht.Name
        On Error GoTo 1
        Cells(a + 1, 2).Value = sht.Cells.Find("*", , , , , 2).Row: GoTo 2
1:        Cells(a + 1, 2).Value = "Empty"
2:        a = a + 1
    Next sht
End Sub

Sub Test()
    Dim ws          As Worksheet
    Dim r           As Long

    For Each ws In ThisWorkbook.Worksheets
        Cells(r + 1, 1).Value = ws.Name

        If ws.UsedRange.Address = "$A$1" Then
            Cells(r + 1, 2).Value = "Empty"
        Else
            Cells(r + 1, 2).Value = ws.Cells.Find("*", , , , , 2).Row
        End If
        r = r + 1
    Next ws
End Sub

المشاركة الأصلية كتبت بواسطة: YasserKhalil الله ينور يا سمسم .. بس لي اعتراض على استخدام جمل القفز بهذا الشكل
يمكن التعامل مع الكود بهذا الشكل أفضل

CODE

Sub Test()
    Dim ws          As Worksheet
    Dim r           As Long

    For Each ws In ThisWorkbook.Worksheets
        Cells(r + 1, 1).Value = ws.Name

        If ws.UsedRange.Address = "$A$1" Then
            Cells(r + 1, 2).Value = "Empty"
        Else
            Cells(r + 1, 2).Value = ws.Cells.Find("*", , , , , 2).Row
        End If
        r = r + 1
    Next ws
End Sub

رائع كالعادة أستاذى الحبيب ياسر
مشكور لمرورك ولمساتك الفنية التى لا غنى عنها

الله ينور يا اسلام يا غالى حل رائع