کاربرگ های مرتب سازی بر اساس منطقه

Question

کوئن یک ورک بوک حاوی 150 کاربرگ دارد که یک برگه برای هر شعبه شرکت است. او باید آن برگه ها را بر اساس منطقه ای که هر شاخه به آن تعلق دارد مرتب کند. (پنج منطقه در شرکت او وجود دارد.) او همچنین خاطرنشان می کند که اگر رنگ برگه برای هر کاربرگ بتواند منطقه را منعکس کند بسیار عالی خواهد بود، و متعجب است که آیا چنین مرتب سازی در اکسل امکان پذیر است.

بله، چنین مرتب سازی ممکن است، اما نیاز به استفاده از یک ماکرو دارد. سخت ترین بخش ایجاد ماکرو این است که چگونه تعیین کنید کدام شاخه ها در کدام منطقه هستند. شاید ساده ترین راه برای انجام این کار این باشد که مطمئن شوید کاربرگ های شما از یک الگوی نام گذاری استفاده می کنند که شامل اطلاعات منطقه و شاخه است. به عنوان مثال، ممکن است کاربرگ ها را چیزی مانند "Reg01-Branch123" نام گذاری کنید. سپس ماکرو شما می تواند از هر کاربرگ عبور کند و رنگ آمیزی و مرتب سازی را انجام دهد.

Sub SortWorksheets()
    Dim iReg As Integer
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer
    Dim ws As Worksheet

    Application.ScreenUpdating = False

     Set tab colors
    For Each ws in Worksheets
        iReg = Val(Mid(ws.Name,4,2))
        Select Case iReg
            Case 1
                ws.Tab.Color = vbRed
            Case 2
                ws.Tab.Color = vbYellow
            Case 3
                ws.Tab.Color = vbBlue
            Case 4
                ws.Tab.Color = vbGreen
            Case 5
                ws.Tab.Color = vbCyan
            Case Else
                ws.Tab.ColorIndex = xlColorIndexNone
        End Select
    Next ws

     Sort the worksheets
    For I = 1 To Sheets.Count - 1
        K = I
        For J = I + 1 To Sheets.Count
            If UCase(Sheets(K).Name) > UCase(Sheets(J).Name) Then K = J
        Next J
        If K <> I Then Sheets(K).Move Before:=Sheets(I)
    Next I

    Application.ScreenUpdating = True
End Sub

ماکرو دو بار از طریق مجموعه Worksheets کار می کند. در اولین عبور، شماره منطقه از نام کاربرگ ها استخراج می شود. سپس از این (در ساختار Select Case) برای تنظیم رنگ برگه استفاده می شود. اگر شماره منطقه خارج از محدوده 1-5 باشد، تغییری در رنگ برگه ایجاد نمی شود.

اگر تعیین اینکه کدام شاخه در کدام منطقه است پیچیده تر است، باید ماکرو را بر این اساس تنظیم کنید. به عنوان مثال، شما ممکن است یک کاربرگ به نام "Region Key" داشته باشید که در ستون A، نام هر یک از شاخه های شما و در ستون B، شماره منطقه مربوط به هر یک از آن شاخه ها وجود دارد. با فرض اینکه داده های واقعی در ردیف 2 شروع می شوند، می توانید ماکرو را به روش زیر تغییر دهید:

Sub SortWorksheets2()
    Dim sTemp As String
    Dim iReg As Integer
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer
    Dim ws As Worksheet
    Dim key As Worksheet

    Application.ScreenUpdating = False

    Set key = Worksheets("Region Key")

     Set tab colors
    For Each ws in Worksheets
        sTemp = UCase(ws.Name)
        I = 2     Beginning row number
        iReg = 0
        While key.Cells(I, 1) > ""
            If UCase(key.Cells(I, 1)) = sTemp Then iReg = key.Cells(I, 2)
            I = I + 1
        Wend
        Select Case iReg
            Case 1
                ws.Tab.Color = vbRed
            Case 2
                ws.Tab.Color = vbYellow
            Case 3
                ws.Tab.Color = vbBlue
            Case 4
                ws.Tab.Color = vbGreen
            Case 5
                ws.Tab.Color = vbCyan
            Case Else
                ws.Tab.ColorIndex = xlColorIndexNone
        End Select
    Next ws

     Sort the worksheets
    For I = 1 To Sheets.Count - 1
        K = I
        For J = I + 1 To Sheets.Count
            If UCase(Sheets(K).Name) > UCase(Sheets(J).Name) Then K = J
        Next J
        If K <> I Then Sheets(K).Move Before:=Sheets(I)
    Next I
    Sheets("Region Key").Move Before:=Sheets(1)

    Application.ScreenUpdating = True
End Sub

بزرگترین تفاوت این ماکرو با قبلی این است که شماره منطقه را از یک کاربرگ می گیرد. به عنوان آخرین اقدام در ماکرو، کاربرگ "کلید منطقه" به همان ابتدای مجموعه کاربرگ ها منتقل می شود.

توجه داشته باشید که این ماکرو دوم همچنین می تواند باعث شود که برگه های کاربرگ شما، در پایین پنجره برنامه، مانند یک کالیدوسکوپ از رنگ ها به نظر برسد. دلیل این امر این است که برگه ها بر اساس نامشان مرتب شده اند نه بر اساس رنگشان. این با ماکرو اول متفاوت است، که به طور موثر بر اساس منطقه و سپس بر اساس شاخه مرتب می شود زیرا کاربرگ ها با استفاده از آن الگو نامگذاری شده اند. اگر می خواهید همچنان از رویکرد «کلید منطقه» استفاده کنید و بر اساس منطقه و سپس شاخه مرتب سازی کنید، می توانید با کمی بیشتر تنظیم ماکرو این کار را انجام دهید:

Sub SortWorksheets3()
    Dim sTemp As String
    Dim sSortArray(499) As String
    Dim iReg As Integer
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer
    Dim ws As Worksheet
    Dim key As Worksheet

    Application.ScreenUpdating = False

    Set key = Worksheets("Region Key")

     Set tab colors and build sort array
    J = 0
    For Each ws in Worksheets
        sTemp = UCase(ws.Name)
        I = 2     Beginning row number
        iReg = 0
        While key.Cells(I, 1) > ""
            If UCase(key.Cells(I, 1)) = sTemp Then iReg = key.Cells(I, 2)
            I = I + 1
        Wend

        J = J + 1
        sSortArray(J) = Right("00" & iReg, 2) & " " & ws.Name

        Select Case iReg
            Case 1
                ws.Tab.Color = vbRed
            Case 2
                ws.Tab.Color = vbYellow
            Case 3
                ws.Tab.Color = vbBlue
            Case 4
                ws.Tab.Color = vbGreen
            Case 5
                ws.Tab.Color = vbCyan
            Case Else
                ws.Tab.ColorIndex = xlColorIndexNone
                 Force into incorrect region area for sort
                sSortArray(J) = "00 " & ws.Name
        End Select
    Next ws

     Sort the worksheets
    For I = 1 To Sheets.Count - 1
        K = I
        For J = I + 1 To Sheets.Count
            If UCase(sSortArray(K)) > UCase(sSortArray(J)) Then K = J
        Next J
        If K <> I Then
            Sheets(K).Move Before:=Sheets(I)
            sTemp = sSortArray(K)
            For J = K To I Step -1
                sSortArray(J) = sSortArray(J-1)
            Next J
            sSortArray(I) = sTemp
        End If
    Next I
    Sheets("Region Key").Move Before:=Sheets(1)

    Application.ScreenUpdating = True
End Sub

توجه داشته باشید که این تکرار ماکرو به یک آرایه کمکی (sSortArray) برای پیگیری نحوه مرتب سازی نام ها در کاربرگ ها متکی است.