[حل شده] راهنمایی

[pooria_713]

سلام دوستان
این کد تمام مواردی که فیلتر نشده رو حذف میکه اما میخوام روی تمام شیتها با یک بار اجرا اعمال بشه این کدشه:
Sub RemoveHiddenRows()
Dim xRow As Range
Dim xRg As Range
Dim xRows As Range
On Error Resume Next
Set xRows = Intersect(ActiveSheet.Range("A:A").EntireRow, ActiveSheet.UsedRange)
If xRows Is Nothing Then Exit Sub
For Each xRow In xRows.Columns(1).Cells
If xRow.EntireRow.Hidden Then
If xRg Is Nothing Then
Set xRg = xRow
Else
Set xRg = Union(xRg, xRow)
End If
End If
Next
If Not xRg Is Nothing Then
xRg.EntireRow.Delete
End If
End Sub

[Amir Ghasemiyan]

سلام دوست عزیز
کدتون رو اصلاح کردم

Sub RemoveHiddenRows()
Dim xRow As Range
Dim xRg As Range
Dim xRows As Range
Dim sht As Worksheet
On Error Resume Next
i = 1
While i <= ThisWorkbook.Worksheets.Count
    Set xRows = Intersect(ActiveSheet.Range("A:A").EntireRow, ActiveSheet.UsedRange)
    If xRows Is Nothing Then Exit Sub
    For Each xRow In xRows.Columns(1).Cells
        If xRow.EntireRow.Hidden Then
            If xRg Is Nothing Then
                Set xRg = xRow
            Else
                Set xRg = Union(xRg, xRow)
            End If
        End If
    Next
    If Not xRg Is Nothing Then xRg.EntireRow.Delete
    i = i + 1
    If i < ThisWorkbook.Worksheets.Count Then ActiveSheet.Next.Select
Wend
End Sub

[pooria_713]

تست کردم بازم جواب نداد

[Amir Ghasemiyan]

تست کردم بازم جواب نداد

این کد رو باید تو شیت اول اجرا کنید
اگر باز هم جواب نگرفتین فایلتون رو بفرستین بررسی کنم

[pooria_713]

توی شیت اول هم اجرا کردم بازم نشد
این فایل و چک کنید
با تشکر
لیست واحد ها.xlsx

[pooria_713]

داداش اگه راهی هستش ممنون میشم راهنمایی کنید

[pooria_713]

دوستان من از جایی یه حلقه به کد اضافه کردم اما این یه مشکلی که داره باید توی محیط برنامه نویسی به تعداد شیت ها کد رو اجرا کنم مثلا 8 بار کد رو اجرا کنم اگه بتونید یه کد اضافش کنید که مثلا 10 بار کد خودش اجرا بشه فکر کنم کارم حل بشه
این کد هستش:

Sub AllSheets()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
ActiveWorkbook.Worksheets(I).Select
Dim xRow As Range
Dim xRg As Range
Dim xRows As Range
On Error Resume Next
Set xRows = Intersect(ActiveSheet.Range("A:A").EntireRow, ActiveSheet.UsedRange)
If xRows Is Nothing Then Exit Sub
For Each xRow In xRows.Columns(1).Cells
If xRow.EntireRow.Hidden Then
If xRg Is Nothing Then
Set xRg = xRow
Else
Set xRg = Union(xRg, xRow)
End If
End If
Next
If Not xRg Is Nothing Then
xRg.EntireRow.Delete
End If
Next I
End Sub

[Amir Ghasemiyan]

کد اصلاح شده خدمت شما

Sub AllSheets()
Dim WS_Count As Integer
Dim I As Integer
Dim xRow As Range
Dim xRg As Range
Dim xRows As Range
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
    ActiveWorkbook.Worksheets(I).Select
    On Error Resume Next
    Set xRg = Nothing
    Set xRows = Intersect(ActiveSheet.Range("A:A").EntireRow, ActiveSheet.UsedRange)
    If xRows Is Nothing Then Exit Sub
    For Each xRow In xRows.Columns(1).Cells
        If xRow.EntireRow.Hidden Then
            If xRg Is Nothing Then
                Set xRg = xRow
            Else
                Set xRg = Union(xRg, xRow)
            End If
        End If
    Next
    If Not xRg Is Nothing Then
    xRg.EntireRow.Delete
    End If
Next I
End Sub

[pooria_713]

مرسی داداش حل شد ممنون از لطفتون