Делаю сводную таблицу. Имеется 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
Диапазон указать для вашей задачи - нет такой возможности в 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