Сводная таблица из нескольких листов

[4uvak111]

nilem, выручай!

[4uvak111]

Итак, имеем макрос

Sub Обновить()
Dim x, y(), wsh As Worksheet, i As Long, r As Range
ReDim y(1 To ThisWorkbook.Worksheets.Count - 1, 1 To 5)

For Each wsh In ThisWorkbook.Worksheets
    If Not wsh Is ActiveSheet Then
        If Not wsh.Name = "Шаблон" Then
        x = wsh.Range("B2:D10").Value
        i = i + 1: y(i, 1) = i: y(i, 2) = x(1, 3)
        y(i, 3) = x(9, 2): y(i, 4) = x(9, 3): y(i, 5) = wsh.Name
    End If
    End If
Next wsh
Range("A2:E" & Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
[a2:e2].Resize(i).Value = y
For Each r In [e2].Resize(i)
    r.Hyperlinks.Add anchor:=r, Address:="", SubAddress:="'" & r.Value & "'" & "!B2"
Next r
End Sub

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

Сама книга: http://rghost.ru/37887688

[Hugo121]

Если бы разобрали код - уже бы и сами сделали.
Что там происходит - сперва создаётся массив размером по количеству листов и строк на каждый лист, потом он заполняется из массива, который берётся с листа.
Вот и измените код соответствующе - создайте массив повыше (из расчёта 2 строки на лист), раскладывайте как Вам нужно данные из массива с листа.

[nilem]

Эх, 4uvak111, всего-то 2 строчки изменить:

Sub ertert()
Dim x, y(), wsh As Worksheet, i As Long, r As Range
'в 2 раза увеличиваем 1-ю размерность выходного массива
ReDim y(1 To ThisWorkbook.Worksheets.Count * 2, 1 To 5)

For Each wsh In ThisWorkbook.Worksheets
    If Not wsh Is ActiveSheet Then
        If Not wsh.Name = "шаблон" Then
            x = wsh.Range("B2:D10").Value
            i = i + 1: y(i, 1) = i: y(i, 2) = x(1, 3)
            y(i, 3) = x(9, 2): y(i, 4) = x(9, 3): y(i, 5) = wsh.Name
            'а здесь дописываем элементы массива - отчет и что-то там еще
            y(i + 1, 3) = x(8, 2): y(i + 1, 4) = x(8, 3): i = i + 1
        End If
    End If
Next wsh
Range("A2:E" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Clear
With [a2:e2].Resize(i)
    .Value = y: .Borders.LineStyle = 1 'можно еще рамочки нарисовать - бонус :)
End With
For Each r In [e2].Resize(i)
    If Len(r) Then r.Hyperlinks.Add anchor:=r, Address:="", SubAddress:="'" & r.Value & "'" & "!B2"
Next r
End Sub

[4uvak111]

nilem, спасибо... все хорошо, только вот счетчик слева идет как 1, 3, 5, 7...

Hugo121, старался разобраться, экспериментировал, но никак не получалось...

[Hugo121]

Даже счётчик поправить не получается? Поэкспериментируйте

[nilem]

Подсказка: y(i, 1) = i \ 2 + 1

[4uvak111]

If Not wsh.Name = "шаблон" Then
x = wsh.Range("B2:D10").Value
i = i + 1: y(i, 1) = i\2+1: y(i, 2) = x(1, 3)
y(i, 3) = x(9, 2): y(i, 4) = x(9, 3): y(i, 5) = wsh.Name
'а здесь дописываем элементы массива - отчет и что-то там еще
y(i + 1, 3) = x(8, 2): y(i + 1, 4) = x(8, 3): i = i + 1
End If

Вот так вот все работает. Эксперимент с первого раза удался =)
Вновь очень Вам благодарен.

А можно построчно, вкратце сказать, какая строка за что отвечает?
Небольшое понимание кода есть, но только на уровне логики - про циклы, условия, а так же сцепление.

[4uvak111]

Кстати, а возможно будет сделать что нибудь подобное, но с несколькими книгами?
К примеру, предполагается, что будет несколько папок, у каждого человека - доступ только к одной своей папки, в этих папках - книга эксель, все книги - однородные. И еще будет отдельно сводная книга, куда будут выгружаться все однородные данные (текст) из остальных книг. Насколько это реально для реализации в локальной сети?

upd: и вообще, не лучше ли будет это сделать на Asses, или с помощью других программных средств?

[4uvak111]

Собственно, сообразил уже как из нескольких файлов скинуть все данные в один.
Извиняюсь, если мой индусский код кому-то режет глаза

Sub Макрос1()
'
' Макрос1 Макрос
'

Cells.Select
Selection.Clear
Range("A1").Select
Dim X, y, w, i
Dim strFileToOpen
Dim wrkBook As Workbook


X = 1: y = 1: w = 1

strfile = "C:\Сводная книга\лист1.xlsx"
Set wrkBook = Workbooks.Open(strfile)
Do While Cells(X, y).Value <> ""
' Переносим Значение из 1.xls в текущую книгу (с макросом)
ThisWorkbook.Worksheets("Лист1").Cells(w, y).Value = _
                wrkBook.Worksheets("Лист1").Cells(X, y).Value
y = y + 1
If y > 2 Then
X = X + 1: w = w + 1: y = 1:
End If
Loop
wrkBook.Close

X = 1: y = 1
strfile = "C:\Сводная книга\лист2.xlsx"
Set wrkBook = Workbooks.Open(strfile)
Do While Cells(X, y).Value <> ""
' Переносим Значение из 1.xls в текущую книгу (с макросом)
ThisWorkbook.Worksheets("Лист1").Cells(w, y).Value = _
                wrkBook.Worksheets("Лист1").Cells(X, y).Value
y = y + 1:
If y > 2 Then
X = X + 1: w = w + 1: y = 1
End If
Loop
wrkBook.Close

X = 1: y = 1
strfile = "C:\Сводная книга\лист3.xlsx"
Set wrkBook = Workbooks.Open(strfile)
Do While Cells(X, y).Value <> ""
' Переносим Значение из 1.xls в текущую книгу (с макросом)
ThisWorkbook.Worksheets("Лист1").Cells(w, y).Value = _
                wrkBook.Worksheets("Лист1").Cells(X, y).Value
y = y + 1:
If y > 2 Then
X = X + 1: w = w + 1: y = 1
End If
Loop
wrkBook.Close

Set wrkBook = Nothing

End Sub

Для организации одного нормального цикла не хватает массива строк (user1,user2,user3 и т.д.) для подстановки этих значений в путь ("c:\" & arr[1] & "\лист1.xtml"). Массив будет статистический, ну или изменятся только на одном компьютере. С этим, думаю, разберусь, надо только немного почитать и посмотреть коды.

Теперь проблема номер два. Как видно из вышеизложенного кода, лист из которого берутся данные сначала открывается, а потом закрывается. А как быть, если данный лист открыт на другом компьютере? (все это будет работать в сети)
Пробовал использовать функцию bBookOpen:

Function bBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook
    For Each wbBook In Workbooks
        If wbBook.Name <> ThisWorkbook.Name Then
            If Windows(wbBook.Name).Visible Then
                If wbBook.Name = wbName Then bBookOpen = True: Exit For
            End If
        End If
    Next wbBook
End Function

http://www.excel-vba.ru/chto-umeet-e...ryta-li-kniga/

Не помогло... Толи лыжи не едут, толи Я.... пока что не всего понимаю...