Форум по VBA и MS Office

Sub Макрос()

    Dim shSrc As Worksheet, shRes As Worksheet, res()
    Dim lr As Long
   
   
    '1. Отключение монитора, чтобы ускорить работу макроса и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '2. Присваивание имени листу-источнику.
    Set shSrc = Worksheets("исходный")
   
    '3. Отображение скрытых строк, чтобы найти последнюю строку.
        ' Метод End не ищет в скрытых строках.
    If shSrc.AutoFilterMode = True Then
        shSrc.AutoFilter.ShowAllData
    End If
    shSrc.Rows.Hidden = False
   
    '4. Обработка данных. Обработанные данные запишутся в массив "res".
    Process shSrc, res()
   
    '5. Создание листа-результата. Учитывается, если лист-шаблон будет скрыт.
    ' Копирование перед, а не сразу после, т.к. если есть скрытые листы,
        ' то потом сложно найти вставленный лист - нужно анализировать скрытые листы.
    Worksheets("шаблон").Copy Before:=shSrc
    Set shRes = shSrc.Previous
    shRes.Visible = True
    shRes.Move After:=shSrc
    ' Ошибка будет, если уже есть лист с таким именем.
    On Error Resume Next
        shRes.Name = "Результат"
    On Error GoTo 0
   
    '6. Вставка массива "res" на лист-результат.
    shRes.Range("A2").Resize(UBound(res, 1), 6).Value = res()
   
    '7. Копирование оформления из строки 2 во все остальные строки.
    lr = shRes.UsedRange.Rows.Count
    If lr > 2 Then
        shRes.Rows(2).Copy
        shRes.Rows("2:" & lr).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        shRes.Range("A1").Select
    End If
   
    '8. Вкл. монитора.
    Application.ScreenUpdating = True
   
End Sub

Private Sub Process(shSrc As Worksheet, res())

    ' Обработка данных.
   
    Dim src(), lr As Long, i As Long, r As Long
   
   
    '1. В столбце B удаление повторов, в столбце F объединение данных в одну ячейку.
    ' Копирование данных в массив. С массивом быстрее работать, чем с эксель-ячейками.
    lr = shSrc.Cells(shSrc.Rows.Count, "B").End(xlUp).Row
    src() = shSrc.Range("A1:S" & lr).Value
   
    ' В столбце B удаление повторов, в столбце F объединение данных в одну ячейку.
    For i = UBound(src, 1) To 3 Step -1
        If src(i, 2) = src(i - 1, 2) Then
            src(i, 2) = Empty
            src(i - 1, 6) = src(i - 1, 6) & ";" & src(i, 6)
        End If
    Next i
   
    '2. Копирование данных из массива "src" в массив "res".
        ' Копируются только те строки, у которых не пусто в столбце B.
    ' Создание ячеек в массиве-результате.
        ' Создаётся максимально возможное кол-во строк, т.к. заранее не известо, сколько будет данных.
    ReDim res(1 To UBound(src, 1), 1 To 6)
    For i = 2 To UBound(src, 1)
        If src(i, 2) <> "" Then
            r = r + 1
            res(r, 1) = src(i, 2)
            res(r, 2) = src(i, 6)
            res(r, 3) = src(i, 7)
            res(r, 4) = src(i, 13)
            res(r, 5) = src(i, 18)
            res(r, 6) = src(i, 19)
        End If
    Next i

End Sub

Sub Макрос()

    Dim shSrc As Worksheet, shRes As Worksheet, res()
    Dim lr As Long
   
   
    '1. Отключение монитора, чтобы ускорить работу макроса и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '2. Присваивание имени листу-источнику.
    Set shSrc = Worksheets("исходный")
   
    '3. Отображение скрытых строк, чтобы найти последнюю строку.
        ' Метод End не ищет в скрытых строках.
    If shSrc.AutoFilterMode = True Then
        shSrc.AutoFilter.ShowAllData
    End If
    shSrc.Rows.Hidden = False
   
    '4. Обработка данных. Обработанные данные запишутся в массив "res".
    Process shSrc, res()
   
    '5. Создание листа-результата. Учитывается, если лист-шаблон будет скрыт.
    ' Копирование перед, а не сразу после, т.к. если есть скрытые листы,
        ' то потом сложно найти вставленный лист - нужно анализировать скрытые листы.
    Worksheets("шаблон").Copy Before:=shSrc
    Set shRes = shSrc.Previous
    shRes.Visible = True
    shRes.Move After:=shSrc
    ' Ошибка будет, если уже есть лист с таким именем.
    On Error Resume Next
        shRes.Name = "Результат"
    On Error GoTo 0
   
    '6. Вставка массива "res" на лист-результат.
    InsertToShRes shRes, res()
   
    '7. Копирование оформления из строки 2 во все остальные строки.
    lr = shRes.UsedRange.Rows.Count
    If lr > 2 Then
        shRes.Rows(2).Copy
        shRes.Rows("2:" & lr).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        shRes.Range("A1").Select
    End If
   
    '8. Вкл. монитора.
    Application.ScreenUpdating = True
   
End Sub

Private Sub Process(shSrc As Worksheet, res())

    ' Обработка данных.
   
    Dim src(), arr()
    Dim lr As Long, i As Long, r As Long
   
   
    '1. В столбце B удаление повторов, в столбце F объединение данных в одну ячейку.
    ' Копирование данных в массив. С массивом быстрее работать, чем с эксель-ячейками.
    lr = shSrc.Cells(shSrc.Rows.Count, "B").End(xlUp).Row
    src() = shSrc.Range("A1:S" & lr).Value
   
    ' В столбце B удаление повторов, в столбце F объединение данных в одну ячейку.
    For i = UBound(src, 1) To 3 Step -1
        If src(i, 2) = src(i - 1, 2) Then
            src(i, 2) = Empty
            If src(i, 6) <> "" Then
                If src(i - 1, 6) = "" Then
                    src(i - 1, 6) = src(i, 6)
                Else
                    src(i - 1, 6) = src(i - 1, 6) & ";" & src(i, 6)
                End If
            End If
        End If
    Next i
   
    '2. Копирование данных из массива "src" в массив "res".
        ' Копируются только те строки, у которых не пусто в столбце B.
    ' Создание ячеек в массиве-результате.
        ' Создаётся максимально возможное кол-во строк, т.к. заранее не известо, сколько будет данных.
    ReDim res(1 To UBound(src, 1), 1 To 6)
    For i = 2 To UBound(src, 1)
        If src(i, 2) <> "" Then
            r = r + 1
            res(r, 1) = src(i, 2)
            res(r, 2) = src(i, 6)
            res(r, 3) = src(i, 7)
            res(r, 4) = src(i, 13)
            res(r, 5) = src(i, 18)
            res(r, 6) = src(i, 19)
        End If
    Next i
   
    '3. Удаление пустых строк с конца массива "res".
    arr() = res()
    ReDim res(1 To r, 1 To 6)
    For i = 1 To UBound(res, 1)
        For j = 1 To 6
            res(i, j) = arr(i, j)
        Next j
    Next i
   
End Sub

Private Sub InsertToShRes(shRes As Worksheet, res())

    ' Вставка массива "res" на лист-результат.
        ' В "Excel 2003" не получается вставить массив, если в ячейке массива много символов.
        ' Много символов в столбце 2.
       
    Dim arr(), i As Long
   
    '1. Копирование данных во вспомогательный массив.
    arr() = res()
    '2. Удаление данных в столбце 2.
    For i = 1 To UBound(arr, 1)
        arr(i, 2) = Empty
    Next i
    '3. Вставка массива в эксель.
    shRes.Range("A2").Resize(UBound(arr, 1), 6).Value = arr()
    '4. Вставка столбца 2 по-элементно.
    For i = 1 To UBound(res, 1)
        shRes.Cells(i + 1, "B").Value = res(i, 2)
    Next i
   
End Sub