Sub строки_в_столбцы()
Dim arr As Variant, i As Long, j As Long, lr As Long

With Worksheets("исх") ' исх - изменить на имя листа с исходными данными
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A1:C" & lr)
End With

With Worksheets("res") ' res - изменить на имя листа с результатом
    .Cells.Clear
    .Cells(1, 1) = arr(1, 1)
    .Cells(2, 1) = arr(1, 2)
    .Cells(3, 1) = arr(1, 3)
    For i = 2 To UBound(arr, 1)
        .Cells(1, i) = arr(i, 1)
        .Cells(2, i) = arr(i, 2)
        .Cells(3, i) = arr(i, 3)
    Next i
    Call format_sh(.Name)
End With

End Sub
Private Sub format_sh(shName As String)
Dim lc As Long

    With Worksheets(shName)
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        .Range(.Cells(1, 1), .Cells(1, lc)).EntireColumn.AutoFit
        .Range(.Cells(2, 2), .Cells(2, lc)).NumberFormat = "[$-F400]h:mm:ss AM/PM"
    End With
End Sub

Private Sub ComboBox1_DropButtonClick()
With ThisWorkbook.Worksheets("Sheet1")
    ComboBox1.List = Application.Transpose(.Range("A2:A5"))
End With
End Sub

Private Sub ComboBox2_DropButtonClick()
With ThisWorkbook.Worksheets("Sheet1")
    ComboBox2.List = Application.Transpose(.Range("B1:E1"))
End With
End Sub

Private Sub CommandButton1_Click()
Dim val_1 As Integer, val_2 As Integer

val_1 = find_item(ComboBox1.Value, ComboBox1.List) + 1 ' плюсуем 1, так как смещение в таблице на 1 строку от первой ячейки
val_2 = find_item(ComboBox2.Value, ComboBox2.List) + 1 ' плюсуем 1, так как смещение в таблице на 1 столбец от первой ячейки

With ThisWorkbook.Worksheets("Sheet1")
    .Cells(val_1, val_2) = TextBox1.Text
End With

End Sub
Private Function find_item(what As String, arr As Variant) As Integer
' ищет с помощью линейного поиска значение what в массиве arr
' возвращаемое значение 0 - нет совпадений, любая другая цифра - индес найденного совпадения в массиве arr
Dim i As Integer
find_item = 0
For i = LBound(arr, 1) To UBound(arr, 1)
    If arr(i, 0) = what Then find_item = i + 1: Exit Function
Next i
End Function

Sub merge_columns()
Dim i As Long, j As Long, lc As Long, lr As Long, shTarget As Worksheet
Set shTarget = Worksheets("Лист2") ' Лист2 - имя листа с результатом
shTarget.Cells.Clear ' очищаем ячейки на листе с результатом
With Worksheets("Лист1") ' Лист1 - имя листа с исходной таблицей
    lr = .Cells(1, 1).CurrentRegion.Rows.Count ' определяем последнюю заполненную ячейку в 1 столбце
    lc = .Cells(1, 1).CurrentRegion.Columns.Count ' определяем псоледний заполненный столбец
    j = 2 ' переменная - счетчик
    .Range("A2:A" & lr).Copy shTarget.Range("A2") ' копируем значения из первого столбца _
                                                    в первый столбец листа с результатом, начиная с А2
    For i = 1 To lc - 1 Step 2 ' идем циклом по столбцам с исходной таблицей с шагом 2
        .Cells(1, 1).CurrentRegion.Columns(i + 1).Copy shTarget.Cells(1, j) ' копируем значения из исходной таблицы на Лист с результатом
        .Cells(1, i).Copy shTarget.Cells(1, j) ' копируем заголовок
        j = j + 1 ' увеличиваем счетчик на 1
    Next i
End With
End Sub

Sub Qft()
Dim mySQL As String, myConnect As Object
Dim data As String, generalRange As String, shName As String

Set myConnect = CreateObject("ADODB.Connection")

With Worksheets("Лист2") ' Лист2 - имя листа с таблицей, с которой производим сравнение
    generalRange = "[" & .Name & "$" & Range("A:D").Address(0, 0) & "]"
    shName = .Name
End With

With Worksheets("Лист1") ' имя листа с основной таблицей (куда копируем данные)
    data = "[" & .Name & "$" & .Range("A:K").Address(0, 0) & "]"
End With

myConnect.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source =" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=YES;"""
mySQL = "UPDATE " & data & " as f INNER JOIN " & generalRange & _
    " as t ON t.ИМЯ=f.ИМЯ SET f.Возраст=t.Возраст, f.Рост=t.Рост," & _
    " f.Вес=t.Вес"
myConnect.Execute mySQL

myConnect.Close
Set myConnect = Nothing

Call convert_str_to_int(shName)
End Sub
Private Sub convert_str_to_int(shName As String)
With Worksheets(shName)
            Range("E:E").TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        
            Range("I:I").TextToColumns Destination:=Range("I1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        
            Range("K:K").TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
End With
End Sub 

Sub test()
Dim firstRow As Long, lastRow As Long, lr As Long, CurrentRow As Long, nom As Long
Dim date_, counterparty, store, category, nomenclatureGroup, nomenclature(), count, summ
Dim flag As Boolean, i, level

With Worksheets("tmp")
    .Cells.Clear '  очищаем ячейки на листа с именем tmp
End With
nom = 1 ' переменная-счетчик для массива результатов (см. ниже)
With Worksheets("TDSheet") ' имя TDSheet нужно заменить на имя листа с исходной таблицей
    firstRow = 14 '  первая ячейка (с датой) ПОМЕНЯТЬ НА НУЖНУЮ
    CurrentRow = firstRow ' текущая ячейка (нужна для цикла)
    lastRow = .Cells(.Rows.count, 2).End(xlUp).Row ' определяем последнюю заполненную ячейку на листе с данными (TDSheet)
    Do While CurrentRow <= lastRow ' пока номер текущей строки меньше номера последней заполненной строки
    flag = False ' переменная типа BOOLEAN (для выгрузки результата на лист)
    level = .Cells(CurrentRow, 2).EntireRow.OutlineLevel ' определяем уровень группировки в таблице с данными для текущей строки
        Select Case level
            Case 1 ' если уровень равен 1, то записываем значение строки в переменную date_
                date_ = .Cells(CurrentRow, 2).Value
            Case 2 ' если уровень равен 2, то записываем данные строки в переменнную counterparty
                counterparty = .Cells(CurrentRow, 2).Value
            Case 3 ' если уровень равен 3, то записываем данные строки в переменную store
                store = .Cells(CurrentRow, 2).Value
        End Select
        Do While level > 3 ' пока уровень больше 3 (здесь мы записываем в массив все столбцы итоговой таблицы для выгрузки)
            flag = True ' означает, что цикл выполнился хотя бы один раз
            Select Case level
                Case 4 ' если уровень равен 4, то записываем данные строки в переменнную category
                    category = .Cells(CurrentRow, 2).Value
                Case 5 ' если уровень равен 5, то записываем данные строки в переменнную nomenclatureGroup
                    nomenclatureGroup = .Cells(CurrentRow, 2).Value
                Case 6 ' если уровень равен 6, то записываем данные строки в массив (этот массив в последствие будет выгружаться на лист с результатом
                    ReDim Preserve nomenclature(1 To nom) ' увеличиваем размер массива
                    nomenclature(nom) = date_ & ":" & counterparty & ":" & _
                    store & ":" & category & ":" & _
                    .Cells(CurrentRow, 2).Value & ":" & nomenclatureGroup & ":" & _
                    .Cells(CurrentRow, 3).Value & ":" & .Cells(CurrentRow, 4).Value
                    nom = nom + 1 ' увеличиваем счетчик на 1
            End Select
            CurrentRow = CurrentRow + 1 ' увеличиваем номер строки на 1
            level = .Cells(CurrentRow, 2).EntireRow.OutlineLevel ' определяем уровень группировки в таблице с данными для текущей строки
        Loop
        '===================ВЫГРУЗКА НА ЛИСТ===========================
        If flag Then ' если переменная flag == TRUE
            With Worksheets("tmp") ' имя tmp нужно заменить на имя листа с результатом
                lr = .Cells(.Rows.count, 1).End(xlUp).Row ' определяем последнюю заполненную ячецку на листе с именем tmp
                If lr = 1 Then lr = 0 ' если индекс последней заполненной ячейки = 1, то lr = 0
                For Each i In nomenclature
                    .Cells(lr + 1, 1).Resize(1, UBound(Split(i, ":")) + 1) = Split(i, ":") 'выгружаем данные из массива nomenclature на лист с результатом (tmp)
                    lr = lr + 1 ' увеличиваем номер строки последней заполненной ячейки на 1
                Next i
            End With
            nom = 1
            ReDim nomenclature(1 To nom) ' очищаем массив nomenclature
            CurrentRow = CurrentRow - 1 ' уменьшаем индекс текущей строки на 1
        End If
        '===============КОНЕЦ БЛОКА ВЫГРУЗКИ НА ЛИСТ=====================
        CurrentRow = CurrentRow + 1 ' увеличиваем индекс текущей строки на 1
    Loop
    
End With
'форматирование на листе с результатом
Call TextToColumns_("tmp") ' имя tmp нужно заменить на имя листа с результатом
End Sub
Private Sub TextToColumns_(shName)
With Worksheets(shName)

    .Range("G:G").TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True

    .Range("H:H").TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True

End With
End Sub

Sub test()
Dim data As Range, firstRow As Long, lastRow As Long, flag As Boolean, lr As Long, i
Dim date_, counterparty(), store(), category(), nomenclatureGroup(), nomenclature(), count(), summ()
Dim cntP As Long, st As Long, cat As Long, nomG As Long, nom As Long, cnt As Long, s As Long
Dim level, CurrentRow As Long

cntP = 1: st = 1: cat = 1: nomG = 1: nom = 1: cnt = 1: s = 1
With Worksheets("tmp")
    .Cells.Clear
End With
With Worksheets("TDSheet") ' имя TDSheet нужно заменить на имя листа с исходной таблицей
    firstRow = 14: CurrentRow = firstRow
    lastRow = .Cells(.Rows.count, 2).End(xlUp).Row
    Set data = .Range("B" & firstRow & ":B" & lastRow)
    
    Do While CurrentRow <= lastRow
    flag = False
    level = .Cells(CurrentRow, 2).EntireRow.OutlineLevel
        Select Case level
            Case 1
                date_ = .Cells(CurrentRow, 2).Value
            Case 2
                ReDim Preserve counterparty(1 To cntP)
                counterparty(cntP) = .Cells(CurrentRow, 2).Value
                cntP = cntP + 1
            Case 3
                ReDim Preserve store(1 To st)
                store(st) = .Cells(CurrentRow, 2).Value
                st = st + 1
        End Select
        Do While level > 3
            flag = True
            Select Case level
                Case 4
                    ReDim Preserve category(1 To cat)
                    category(cat) = .Cells(CurrentRow, 2).Value
                    cat = cat + 1
                Case 5
                    ReDim Preserve nomenclatureGroup(1 To nomG)
                    nomenclatureGroup(nomG) = .Cells(CurrentRow, 2).Value
                    nomG = nomG + 1
                Case 6
                    ReDim Preserve nomenclature(1 To nom)
                    nomenclature(nom) = date_ & ":" & counterparty(UBound(counterparty)) & ":" & _
                    store(UBound(store)) & ":" & category(UBound(category)) & ":" & _
                    .Cells(CurrentRow, 2).Value & ":" & nomenclatureGroup(UBound(nomenclatureGroup)) & ":" & _
                    .Cells(CurrentRow, 3).Value & ":" & .Cells(CurrentRow, 4).Value
                    nom = nom + 1
            End Select
            CurrentRow = CurrentRow + 1
            level = .Cells(CurrentRow, 2).EntireRow.OutlineLevel
        Loop
        If flag Then
            With Worksheets("tmp") ' имя tmp нужно заменить на имя листа с результатом
                lr = .Cells(.Rows.count, 1).End(xlUp).Row
                If lr = 1 Then lr = 0
                For Each i In nomenclature
                    .Cells(lr + 1, 1).Resize(1, UBound(Split(i, ":")) + 1) = Split(i, ":")
                    lr = lr + 1
                Next i
            End With
            nom = 1
            ReDim nomenclature(1 To nom)
            CurrentRow = CurrentRow - 1
        End If
        CurrentRow = CurrentRow + 1
    Loop
    
End With
Call TextToColumns_("tmp") ' имя tmp нужно заменить на имя листа с результатом
End Sub
Private Sub TextToColumns_(shName)
With Worksheets(shName)
    .Range("G:G").TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    .Range("H:H").TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
End With
End Sub

Sub uniq_using_regex()
Dim arr, s, i, d As Object, Match As Object
Dim TargetCell As Range

Set d = CreateObject("Scripting.Dictionary")
d.comparemode = vbTextCompare

With Worksheets("Лист1")
    arr = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    With CreateObject("VBScript.Regexp")
        .pattern = "[^,. ]+": .Global = True: .MultiLine = True: .IgnoreCase = True
        For Each i In arr
            If .test(i) Then
                For Each Match In .Execute(i)
                    If Not d.exists(Match.Value) Then d.Add Match.Value, ""
                Next Match
            End If
        Next i
    End With
End With
' выгрузка на лист
Set TargetCell = Application.InputBox("Выберите ячейку для выгрузки результата", Type:=8)
TargetCell.Resize(d.Count, 1) = Application.Transpose(d.keys())
End Sub

Sub uniq_values()
Dim d As Object, arr, item, key
Dim TargetCell As Range
Set d = CreateObject("Scripting.Dictionary")
With Worksheets("Лист1")
    arr = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    For Each item In arr
        For Each key In Split(item, ",")
            If Not d.exists(Trim(LCase(key))) Then d.Add Trim(LCase(key)), ""
        Next key
    Next item
End With
' выгрузка на лист
Set TargetCell = Application.InputBox("Выберите ячейку для выгрузки результата", Type:=8)
TargetCell.Resize(d.Count, 1) = Application.Transpose(d.keys())
End Sub

Sub compare_rows()
Dim arr1, arr2, i As Long, j As Long
With Worksheets("Лист2") ' имя Лист2 - имя листа со второй таблицей
    arr2 = .Range("A1:C" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
With Worksheets("Лист1") ' имя Лист2 - имя листа с первой таблицей (куда подставляем значение)
    arr1 = .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    For i = LBound(arr1, 1) To UBound(arr1, 1)
        For j = UBound(arr2, 1) To LBound(arr2, 1) Step -1
            If arr2(j, 1) = arr1(i, 1) And arr2(j, 2) = arr1(i, 2) Then .Cells(i, 3) = arr2(j, 3)
        Next j
    Next i
End With
End Sub

Sub сумма_по_месяцам()
Dim mySQL As String, myConnect As String, myRecord As Object
Dim oRange As Range, lr As Long, shName As String
Set myRecord = CreateObject("ADODB.Recordset")
With Worksheets("Лист1") ' Лист1 - имя листа с исходной таблицей (поменять на нужное)
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе с именем Лист1
    Set oRange = .Range(.Cells(1, 1), .Cells(lr, 2)) ' формируем диапазон для запроса
    shName = "[" & .Name & "$" & oRange.Address(0, 0) & "]"
End With
    myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source =" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=NO;"""
    mySQL = "SELECT FORMAT([F1], ""mm.yyyy""),SUM([F2]) FROM " & shName & " GROUP BY FORMAT([F1], ""mm.yyyy"")"  ' строка запроса
    myRecord.Open mySQL, myConnect
With Worksheets("Лист2") ' Лист2 - имя листа с результатом
    .Cells.Clear ' очищаем ячейки на листе
    .Cells(1, 1).CopyFromRecordset myRecord ' записываем данные на лист, начиная с ячейки А1
End With
myRecord.Close
Set myRecord = Nothing
End Sub

Sub transform()
Dim title, arr, d As Object, array_of_keys, shResult As Worksheet, shName As String
Dim lr As Long, i As Long, j As Long, k As Long, key, tmp, items

title = Array("Код товара", "Аптека", "Кол-во уп", "Сумма")

With Worksheets("исходник") ' имя исходник - имя листа с исходной таблицей
    arr = .Cells(1, 1).CurrentRegion
End With

Set d = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(arr, 1)
    j = 1
    Do While j < UBound(arr, 2)
        If k > UBound(arr, 2) - 2 Then
            k = 2
        Else
            k = k + 2
        End If
        If Not d.exists(arr(1, k) & "%" & arr(i, 1)) Then
            d.Add arr(1, k) & "%" & arr(i, 1), arr(i, k) & ":" & arr(i, k + 1)
        End If
        j = j + 1
    Loop
Next i

array_of_keys = sort_keys(d.keys()) ' сортируем массив ключей

shName = "tmp" ' имя tmp - имя листа с результатом (поменять на нужное)

If if_sheet_exists(shName) Then
    Set shResult = Worksheets(shName)
Else
    Set shResult = Worksheets.Add(, Worksheets(Sheets.Count))
    shResult.Name = shName
End If

With shResult
    .Cells.Clear
    .Cells(1, 1).Resize(1, UBound(title) + 1) = title
    lr = 2
    For Each key In array_of_keys
        tmp = Split(d(key), ":")
        Debug.Print
        items = Split(key, "%")
        .Cells(lr, 1) = items(1)
        .Cells(lr, 2) = items(0)
        .Cells(lr, 3) = IIf(tmp(0) <> "", tmp(0), 0)
        .Cells(lr, 4) = CDbl(tmp(1))
        lr = lr + 1
    Next key
End With
End Sub
Private Function sort_keys(arr) As Variant
Dim tmp, i As Long, j As Long
For i = LBound(arr) To UBound(arr)
    For j = i To UBound(arr)
        If arr(i) > arr(j) Then
            tmp = arr(j)
            arr(j) = arr(i)
            arr(i) = tmp
        End If
    Next j
Next i
sort_keys = arr
End Function
Private Function if_sheet_exists(shName) As Boolean
Dim sh As Worksheet
On Error GoTo errorH
    Set sh = Worksheets(shName): if_sheet_exists = True: Exit Function
errorH:
    if_sheet_exists = False
End Function

Sub transform()
Dim title, arr, d As Object
Dim lr As Long, i As Long, j As Long, k As Long, key, tmp, items

title = Array("Код товара", "Аптека", "Кол-во уп", "Сумма")

With Worksheets("исходник") ' имя исходник - имя листа с исходной таблицей
    arr = .Cells(1, 1).CurrentRegion
End With

Set d = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(arr, 1)
    j = 1
    Do While j < UBound(arr, 2)
        If k > UBound(arr, 2) - 2 Then
            k = 2
        Else
            k = k + 2
        End If
        If Not d.exists(arr(1, k) & "%" & arr(i, 1)) Then
            d.Add arr(1, k) & "%" & arr(i, 1), arr(i, k) & ":" & arr(i, k + 1)
        End If
        j = j + 1
    Loop
Next i
With Worksheets("tmp") ' имя tmp - имя листа с результатом
    .Cells.Clear
    .Cells(1, 1).Resize(1, UBound(title) + 1) = title
    lr = 2
    For Each key In d.keys()
        tmp = Split(d(key), ":")
        Debug.Print
        items = Split(key, "%")
        .Cells(lr, 1) = items(1)
        .Cells(lr, 2) = items(0)
        .Cells(lr, 3) = IIf(tmp(0) <> "", tmp(0), 0)
        .Cells(lr, 4) = CDbl(tmp(1))
        lr = lr + 1
    Next key
    Call sort_sh(.Name, lr)
End With
End Sub
Private Sub sort_sh(shName As String, lr As Long)
' sort_sh - процедура сортировки таблицы с результатом
' shName: имя листа с результатом
' lr: последняя заполненная ячейка на листе с результатом
    With Worksheets(shName)
        .Activate
        .sort.SortFields.Clear
        .sort.SortFields.Add key:=Range("B2:B" & lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    With Worksheets(shName).sort
        .SetRange Cells(1, 1).CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub