Contrib Sort

MakeChartは月が2桁　1桁にする
6業態：凡例：業態ではなく販売額では？

本省では、身の回り品は衣料品に含まれる

速報：
CVS DB_Table8
EC 　DB_Table12
DGS DB_Table15
HC DB_Table18

どうやって、4業態の品目別寄与度を取得しているか？
全国なら可能。
百スは全国との比較が可能。県別も可能。

Option Explicit

Private Type Contribs
    Item As String
    Contrib As Double
End Type

Private cntItems As Long

Public Sub SortContrib()
    Dim arrContribPlus() As Contribs
    Dim arrContribMinus() As Contribs
    Dim curClm As Long
    Dim contribRow As Long
    Dim iniRow As Long
    Dim iniClm As Long
    Dim titleClm As Long
    Dim cntClm As Long
    Dim iniDataClm As Long
    Dim endDataClm As Long
    Dim isPlus As Boolean
    Dim i As Long
    Dim j As Long
    Dim p As Long
    Dim m As Long
    Dim cnt As Long
    '
    Dim temp As Contribs
    '''並び替え完了
    Dim isSwap As Boolean
    '
    cntItems = 8
    contribRow = 5
    iniRow = 2
    cntClm = 1
    titleClm = 2
    iniClm = 3
    iniDataClm = 4
    endDataClm = 11
    '
    Range(Cells(10, 1), Cells(30, 3)).ClearContents
    ReDim arrContribPlus(cntItems)
    ReDim arrContribMinus(cntItems)
    isPlus = True
    If Cells(contribRow, iniClm) < 0 Then isPlus = False
    i = 0
    p = 0
    m = 0
    For curClm = iniDataClm To endDataClm
        If Cells(contribRow, curClm) >= 0 Then
            arrContribPlus(p).Item = Cells(iniRow, curClm)
            arrContribPlus(p).Contrib = Cells(contribRow, curClm)
            p = p + 1
        Else
            arrContribMinus(m).Item = Cells(iniRow, curClm)
            arrContribMinus(m).Contrib = Cells(contribRow, curClm)
            m = m + 1
        End If
        i = i + 1
    Next curClm
    isSwap = False
    Do Until isSwap
        isSwap = True
        For i = 0 To UBound(arrContribPlus) - 1
            If arrContribPlus(i).Contrib < arrContribPlus(i + 1).Contrib Then
                temp = arrContribPlus(i)
                arrContribPlus(i) = arrContribPlus(i + 1)
                arrContribPlus(i + 1) = temp
                isSwap = False
            End If
        Next i
    Loop
    '
    isSwap = False
    Do Until isSwap
        isSwap = True
        For i = 0 To UBound(arrContribMinus) - 1
            If arrContribMinus(i).Contrib > arrContribMinus(i + 1).Contrib Then
                temp = arrContribMinus(i)
                arrContribMinus(i) = arrContribMinus(i + 1)
                arrContribMinus(i + 1) = temp
                isSwap = False
            End If
        Next i
    Loop
    If isPlus Then
        j = 0
        cnt = 1
        For i = 0 To UBound(arrContribPlus)
            If arrContribPlus(i).Item <> "" Then
                Cells(10 + j, cntClm) = cnt
                Cells(10 + j, titleClm) = arrContribPlus(i).Item
                Cells(10 + j, iniClm) = arrContribPlus(i).Contrib
                cnt = cnt + 1
                j = j + 1
            End If
        Next i
        cnt = 1
        j = j + 2
        For i = 0 To UBound(arrContribMinus)
            If arrContribMinus(i).Item <> "" Then
                Cells(10 + j, cntClm) = cnt
                Cells(10 + j, titleClm) = arrContribMinus(i).Item
                Cells(10 + j, iniClm) = arrContribMinus(i).Contrib
                cnt = cnt + 1
                j = j + 1
            End If
        Next i
    Else
        cnt = 1
        j = 0
        For i = 0 To UBound(arrContribMinus)
            If arrContribMinus(i).Item <> "" Then
                Cells(10 + j, cntClm) = cnt
                Cells(10 + j, titleClm) = arrContribMinus(i).Item
                Cells(10 + j, iniClm) = arrContribMinus(i).Contrib
                cnt = cnt + 1
                j = j + 1
            End If
        Next i
        cnt = 1
        j = j + 2
        For i = 0 To UBound(arrContribPlus)
            If arrContribPlus(i).Item <> "" Then
                Cells(10 + j, cntClm) = cnt
                Cells(10 + j, titleClm) = arrContribPlus(i).Item
                Cells(10 + j, iniClm) = arrContribPlus(i).Contrib
                cnt = cnt + 1
                j = j + 1
            End If
        Next i
    End If
End Sub

条件付き書式　青と赤

=RC3>=0