그룹별 오름차순 정렬 v2

앞서 했던 정렬과는 달리

이번엔 별도의 시트에 순위가 정해져있다.

vlookup 함수를 이용해서 서로의 값을 비교해서 배열을 재정렬하는 매크로 

Option Explicit
Sub Macro()
 
    Dim vData() As Variant
    Dim vList As Variant
    Dim temp As Variant
    Dim i As Integer
    Dim r As Integer
    Dim rngData As Range
    
    Application.ScreenUpdating = False
    
    '연간판매자료 및 정렬기준표 변수 설정
    Set rngData = Range("A5", Cells(Rows.Count, "A").End(xlUp))
    With Sheets("정렬기준표")
        vList = .Range("A2", .Cells(Rows.Count, "B").End(xlUp)).Formula
    End With
    
    '각 제품 데이터를 변수에 삽입
    For r = 1 To rngData.Rows.Count Step Range("A5").MergeArea.Rows.Count
        With Cells(4 + r, "A").MergeArea
            If .Columns.Count = 1 Then
                ReDim Preserve vData(i)
                vData(i) = .Resize(, 18).FormulaR1C1
                i = i + 1
            End If
        End With
    Next r
    
    '정렬기준표에 따라 순위별로 정렬
    For i = 0 To UBound(vData) - 1
        For r = i + 1 To UBound(vData)
            If WorksheetFunction.VLookup(vData(i)(1, 2), vList, 2, 0) > WorksheetFunction.VLookup(vData(r)(1, 2), vList, 2, 0) Then
                temp = vData(r)
                vData(r) = vData(i)
                vData(i) = temp
            End If
        Next r
    Next i
    
    '순위별로 정렬된 배열을 셀에 뿌림
    i = 0
    For r = 1 To rngData.Rows.Count Step Range("A5").MergeArea.Rows.Count
        With Cells(4 + r, "A").MergeArea
            If .Columns.Count = 1 Then
                .Resize(, 18) = vData(i)
                i = i + 1
            End If
        End With
    Next r
    
    Application.ScreenUpdating = True
End Sub

150721.xlsm