Excel VBA Макросы: Копирование данных из нескольких листов, из одной ячейки на другой лист в одну ячейку через запятую.

Автор Wr1TeR, 27 сентября 2018, 16:10

Wr1TeR

Делаю сводную таблицу. Имеется 74 листа, в которые будет вноситься информация от руки.
Могу ли я сделать следующее. Информация допустим из ячейки С4 с каждого листа должна выводиться в сводную таблицу в ячейку С4, но не суммироваться, а идти через запятую.
В идеале - обозначение номера листа, далее значение из ячейки С4 данного листа, если значение нулевое, соответственно никая информация не выводится.

[вложение удалено администратором]

Администратор

Макрос
Sub Макрос()
   
    Dim sh_res As Worksheet, sh_src As Worksheet, i As Long
   
   
    '1. Отключение монитора и пересчёта формул, чтобы ускорить макрос.
    Dim calc As Long: calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
   
    '2. Даём листу-результату имя 'sh_res'.
        ' Далее в коде будем обращаться к листу по этому имени.
    Set sh_res = Worksheets(1)
   
    '3. Копирование данных из листов на сводный лист.
    ' Движение по листам: со второго по последний.
    For i = 2 To Worksheets.Count
   
        ' Даём текущему листу имя 'sh_src'.
        Set sh_src = Worksheets(i)
       
        ' Копируем данные из листа-источника на лист-результат.
        ' Если на листе-источнике не ноль.
        If sh_src.Range("C4").Value <> 0 Then
            ' Если ячейка-результат пустая.
            If sh_res.Range("C4").Value = "" Then
                sh_res.Range("C4").Value = sh_src.Name & " " & sh_src.Range("C4").Value
            ' Если в ячейке-результате есть данные.
            Else
            sh_res.Range("C4").Value = sh_res.Range("C4") & ", " & _
                sh_src.Name & " " & sh_src.Range("C4").Value
            End If
        End If
       
    Next i
   
    '4. Включения.
    Application.Calculation = calc
    Application.ScreenUpdating = True
   
    '5. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub
[свернуть]

Wr1TeR

Спасибо, все работает!
Для каждой ячейки нужно отдельно прописывать или можно диапазон указать?

Администратор

Диапазон указать для вашей задачи - нет такой возможности в VBA - нужно работать с каждой ячейкой.
Для каких-то других задач можно указать диапазон.

В макросе ниже, в процедуре 'Макросы', в пункте 2 указывайте адреса фрагментов по аналогии.
В макросе две процедуры. Поместите их в одни модуль. Запускать нужно процедуру 'Макрос'.

Макрос
Sub Макрос()
   
    '1. Отключение монитора и пересчёта формул, чтобы ускорить макрос.
    Dim calc As Long: calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
   
    '2. Копироваие данных из листов на сводный лист.
    Functional "C4:AA13"
    Functional "C17:AA24"

    '3. Включения.
    Application.Calculation = calc
    Application.ScreenUpdating = True
   
    '4. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Sub Functional(address As String)
   
    Dim sh_res As Worksheet, sh_src As Worksheet, res(), src()
    Dim i_sh As Long, i As Long, j As Long
   
   
    '1. Даём листу-результату имя 'sh_res'.
        ' Далее в коде будем обращаться к листу по этому имени.
    Set sh_res = Worksheets(1)
   
    '2. Копирование данных из листов на сводный лист.
    ' Движение по листам: со второго по последний.
    For i_sh = 2 To Worksheets.Count
   
        '1) Даём текущему листу имя 'sh_src'.
        Set sh_src = Worksheets(i_sh)
       
        '2) Копируем данные из листов в vba-массивы, т.к. с ними
            ' макрос быстрее работает, чем с эксель-ячейками.
        res() = sh_res.Range(address).Value
        src() = sh_src.Range(address).Value
       
        '3) Копируем данные из массива-источника в массив-результат.
        For i = 1 To UBound(res, 1)
            For j = 1 To UBound(res, 2)
                If src(i, j) <> 0 Then
                    If res(i, j) = "" Then
                        res(i, j) = sh_src.Name & " " & src(i, j)
                    Else
                        res(i, j) = res(i, j) & ", " & sh_src.Name & " " & src(i, j)
                    End If
                End If
            Next j
        Next i
       
        '4) Вставка массива на лист-результат.
        sh_res.Range(address).Value = res()
       
    Next i_sh
   
End Sub
[свернуть]