نمایش نتایج: از شماره 1 تا 9 , از مجموع 9

موضوع: راهنمایی

  1. #1


    آخرین بازدید
    2022/11/29
    تاریخ عضویت
    August 2017
    نوشته ها
    15
    امتیاز
    11
    سپاس
    7
    سپاس شده
    1 در 1 پست
    تعیین سطح نشده است

    راهنمایی

    سلام دوستان
    این کد تمام مواردی که فیلتر نشده رو حذف میکه اما میخوام روی تمام شیتها با یک بار اجرا اعمال بشه این کدشه:
    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
    اخطار: این یک موضوع قدیمی است
    به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.
    پاسخ مورد نظر براي اين تاپيك ارسال شده است.

  2.  

  3. #2


    آخرین بازدید
    22 ساعت پیش
    تاریخ عضویت
    September 2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    4,469
    امتیاز
    12312
    سپاس
    8,924
    سپاس شده
    10,583 در 3,742 پست
    سطح اکسل
    100.00 %

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

    کد:
    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


  4. سپاس ها (1)


  5. #3


    آخرین بازدید
    2022/11/29
    تاریخ عضویت
    August 2017
    نوشته ها
    15
    امتیاز
    11
    سپاس
    7
    سپاس شده
    1 در 1 پست
    تعیین سطح نشده است

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

  6. #4


    آخرین بازدید
    22 ساعت پیش
    تاریخ عضویت
    September 2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    4,469
    امتیاز
    12312
    سپاس
    8,924
    سپاس شده
    10,583 در 3,742 پست
    سطح اکسل
    100.00 %

    نقل قول نوشته اصلی توسط pooria_713 نمایش پست ها
    تست کردم بازم جواب نداد

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

  7. سپاس ها (1)


  8. #5


    آخرین بازدید
    2022/11/29
    تاریخ عضویت
    August 2017
    نوشته ها
    15
    امتیاز
    11
    سپاس
    7
    سپاس شده
    1 در 1 پست
    تعیین سطح نشده است

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

  9. #6


    آخرین بازدید
    2022/11/29
    تاریخ عضویت
    August 2017
    نوشته ها
    15
    امتیاز
    11
    سپاس
    7
    سپاس شده
    1 در 1 پست
    تعیین سطح نشده است

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

  10. #7


    آخرین بازدید
    2022/11/29
    تاریخ عضویت
    August 2017
    نوشته ها
    15
    امتیاز
    11
    سپاس
    7
    سپاس شده
    1 در 1 پست
    تعیین سطح نشده است

    دوستان من از جایی یه حلقه به کد اضافه کردم اما این یه مشکلی که داره باید توی محیط برنامه نویسی به تعداد شیت ها کد رو اجرا کنم مثلا 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

  11. #8


    آخرین بازدید
    22 ساعت پیش
    تاریخ عضویت
    September 2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    4,469
    امتیاز
    12312
    سپاس
    8,924
    سپاس شده
    10,583 در 3,742 پست
    سطح اکسل
    100.00 %

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

    کد:
    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


  12. سپاس ها (1)


  13. #9


    آخرین بازدید
    2022/11/29
    تاریخ عضویت
    August 2017
    نوشته ها
    15
    امتیاز
    11
    سپاس
    7
    سپاس شده
    1 در 1 پست
    تعیین سطح نشده است

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


اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. غیر فعال کردن قسمت بالایی یوزرفرم جهت عدم امکان جابجایی فرم
    توسط mohammad59 در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 0
    آخرين نوشته: 2016/11/15, 10:44
  2. تقاضایی راهنمایی در مورد ماکرونویسی
    توسط newertebat در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 4
    آخرين نوشته: 2014/11/09, 01:01

بازدید کنندگان با جستجو های زیر این صفحه را پیدا کرده اند

انجمن اكسل ايران , اكسل , اكسس , سوال و جواب اكسل , سوال اكسس , انجمن اكسل ايران , توابع اكسل, آموزش اكسل, آموزش اكسس, VBA, ويژوال بيسيك

علاقه مندی ها (Bookmarks)

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
  • BB code ها فعال هستند
  • شکلک ها فعال هستند
  • کد [IMG] فعال است
  • کد [VIDEO] فعال است
  • کد HTML غیر فعال است