Page Comparison

Dim idx_row, idx_group, j, k, idx_from, idx_to As Long
Dim group_full As String
Dim group_col As Integer

'индекс листа
SHEET_IDX = 1

'строка с которой начинается прайс
START_ROW = 13
CLM_LAST = "ZZ" 'последняя колонка в прайсе, буквами

CLMS_LIST = Array(1) 'список индексов колонок, в каком порядке их нужно объединять, индексы колонок вводятся через запятую
'CLMS_LIST = Array(3, 4, 5) 'пример если несколько колонок групп

CHR_DELIMITER = " >> " 'разделитель между группами

CLM_GROUP_IDX = 2 'номер колонки с группой (в нее помещается объединенная группа)
CLM_GROUP_L = "B" 'буква колонки с группой (соответствует CLM_GROUP_IDX, только буква)
CLM_GROUP_LEVEL = 20 'номер колонки с уровнем группировки
CLM_PRICE = 9 'колонка, в которой указана цена товара

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Set SHT = Sheets(SHEET_IDX)
SHT.Select
Cells.Select
Selection.ClearOutline
Selection.UnMerge

SHT.Cells(1, 1).Select

row_count = SHT.UsedRange.Rows.Count
prev_level = Array("", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "")

'формируем группы из нескольких колонок
For i = START_ROW To row_count
	group_text = ""
	If Sht.Cells(i, CLM_PRICE).Value <> "" Then
		For j = LBound(CLMS_LIST) To UBound(CLMS_LIST)
			clm_group = CLMS_LIST(j)
			
			If SHT.Cells(i, clm_group).Value <> "" Then
				If (group_text = "") Then
					group_text = Trim(SHT.Cells(i, clm_group).Value)
				Else
					group_text = group_text & CHR_DELIMITER & Trim(SHT.Cells(i, clm_group).Value)
				End If
			Else
			   Exit For
			End If
		Next j
				
		If group_text <> "" Then
			SHT.Cells(i, CLM_GROUP_IDX).Value = group_text
		Else
			SHT.Cells(i, CLM_GROUP_IDX).Value = "не распределено"
		End If
	Else
		Sht.Cells(i, CLM_GROUP_IDX).Value = ""
	End if
Next i


'сортировка по колонке с группой
Columns(CLM_GROUP_L & ":" & CLM_GROUP_L).Select
SHT.Sort.SortFields.Clear
SHT.Sort.SortFields.Add Key:=Range(CLM_GROUP_L & "1"), _
	SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With SHT.Sort
	.SetRange Range("A" & CStr(START_ROW) & ":" & CLM_LAST & CStr(row_count))
	.Header = xlNo
	.MatchCase = False
	.Orientation = xlTopToBottom
	.SortMethod = xlPinYin
	.Apply
End With


'Добавление строчек с группами
idx_row = START_ROW

Do While ActiveSheet.Cells(idx_row, CLM_GROUP_IDX).Value <> ""
	group_full = ActiveSheet.Cells(idx_row, CLM_GROUP_IDX).Value
	ActiveSheet.Cells(idx_row, CLM_GROUP_LEVEL).Value = ""
	
	'Разделитель
	group_part = Split(group_full, CHR_DELIMITER)
			
	For i = LBound(group_part) To UBound(group_part)
		If group_part(i) <> prev_level(i) Then
			Rows(CStr(idx_row) & ":" & CStr(idx_row)).Select
			Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
			
			ActiveSheet.Cells(idx_row, CLM_GROUP_LEVEL).Value = i + 1
			ActiveSheet.Cells(idx_row, CLM_GROUP_IDX).Value = group_part(i)
			prev_level(i) = group_part(i)
			
			idx_row = idx_row + 1
		End If
	Next i
	
	idx_row = idx_row + 1
Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Перед копированием макроса из инструкции переключите раскладку клавиатуры на русский язык