Страницы: 1
RSS
Сбор данных с разных листов одной книги на итоговый лист с переименованием столбцов в имена листов гиперссылкой, VBA, для общего ознакомления
 
Уважаемые форумчане, я изначально прошу прощения, поискал страницы со сбором данных - их достаточное количество, но я не смог найти для себя необходимого материала, да и вдруг будет полезно кому.
Имеется файл, грубо говоря школьный журнал. Каждый лист имеет наименование - фио ученика. На каждом листе его личный дневник, т.е. если он гуманитарий - то одни предметы, если инженер - другие.
Задача: В журнале есть общая страница. На ней есть одна кнопка к которой и должен быть привязан макрос. При нажатии на нее На этой странице формируется таблица, С предметами, которые участвуют во всех созданный и вновь созданных страницах. И заполняется как это указано в приложенном файле. Столбцы в свою очередь подписываются именами листов (а если это будет гиперссылкой, то вообще будет великолепно). Гиперссылка позволит перейти на лист того ученика чьи оценки будут нуждаться в подробном изучении.
Я смотрел и раздел Приемы и листал форум. Было найдено огромное количество вариаций, но переделать под такую задачу я не смог.
 
Сразу же покажу что было найдено, и что я уже пытался переделать. Но моих знаний в VBA (точнее отсутствие этих самых знаний) не помогло мне решить данную задачу
Код
Sub СборИнформации()
Dim iSht As Worksheet
Dim iShtOpis As Worksheet
Dim Osnovanie As Range
Dim VsegoNaklad As Range
Dim i As Long
Dim lColumn As Long, LastColumn As Long

Application.ScreenUpdating = False
On Error Resume Next
Set iShtOpis = Sheets("Итог")
If iShtOpis Is Nothing Then
Set iShtOpis = Sheets.Add(Before:=Worksheets(1))
iShtOpis.Name = "Итог"
On Error GoTo 0
End If
Sheets(iShtOpis.Name).UsedRange.Clear
i = 2
For Each iSht In ThisWorkbook.Sheets
If iSht.Name <> iShtOpis.Name Then
If i > 2 Then
i = 3
LastColumn = iShtOpis.Cells(1, Columns.Count).End(xlToRight).Column + 1
Else: LastColumn = 1
End If
With iSht
lColumn = .Cells(2, Columns.Count).End(xlToRight).Column
If lColumn > 2 Then
.Range(.Cells(i, 1), .Cells(20, lColumn)).Copy iShtOpis.Cells(1, LastColumn)
End If
i = i + 1
End With
End If
Next
With iShtOpis
With iShtOpis.UsedRange.Cells
.Value = .Value
End With
End With
Application.ScreenUpdating = True
End Sub

Sub Заполнение()
Dim i As Integer, LastColumn As Long, FreeColumn As Long, StartColumn As Long
    FreeColumn = Cells(1, Columns.Count).End(xlToRight).Column + 1
    Range(Cells(1, 1), Cells(4, FreeColumn + 1)).ClearContents
    FreeColumn = 1
    For i = 2 To Sheets.Count
        With Sheets(i)
            LastColumn = .Cells(1, Columns.Count).End(xlToRight).Column
            StartColumn = FreeColumn
            Range(.Cells(1, 1), .Cells(15, LastColumn)).Copy Cells(2, FreeColumn)
            FreeColumn = Cells(2, Columns.Count).End(xlToRight).Column
            Range(Cells(2, StartColumn), Cells(2, FreeColumn)).Value = Sheets(i).Name
            FreeColumn = FreeColumn + 1
        End With
    Next
End Sub
 
вариант в Power Query
Код
let
    адрес= Table.SelectRows(Excel.CurrentWorkbook(), each ([Name] = "адрес"))[Content]{0}[Column1]{0},
    Source = Excel.Workbook(File.Contents(адрес)),
    #"Filtered Rows" = Table.SelectRows(Source, each [Name] <> "Итог" and [Kind] = "Sheet"),
    #"Added Custom" = Table.AddColumn(#"Filtered Rows", "abc", each Table.PromoteHeaders([Data], [PromoteAllScalars=true])),
    #"Removed Other Columns" = Table.SelectColumns(#"Added Custom",{"Name", "abc"}),
    #"Expanded {0}" = Table.ExpandTableColumn(#"Removed Other Columns", "abc", {"максимальный балл", "Оценки", "получено"}, {"максимальный балл", "Оценки", "получено"}),
    #"Pivoted Column" = Table.Pivot(#"Expanded {0}", List.Distinct(#"Expanded {0}"[Name]), "Name", "получено"),
    #"Demoted Headers" = Table.DemoteHeaders(#"Pivoted Column")
in
    #"Demoted Headers"
 
artyrH, читал про эту надстройку, даже что то у самого тогда получилось дома реализовать, а вот на работе в связи с работой через общий сервер и отсутствием возможно установки надстройки, не могу, и искал как раз решение через макрос. Офис 2013
Так что огромное спасибо за Вашу отзывчивость, но применить не смогу :cry:  
 
Iluxa, смотрите сами. можно надстройку скачать на флешку и потом установить на работе
 
artyrH, к сожалению пресекается такая возможность у нас(
боятся что установим что то, что убьет и без того еле дышащую систему)  
 
Цитата
Iluxa написал:
еле дышащую систему)
в последние годы часто слышу
 
Iluxa, Попробуйте так.
Код
Sub csg()
Dim iSheet As Long, i As Long, j As Long, j2 As Long, a As Long, LR As Long, LR1 As Long, LCol As Long
Dim myRange As Range, myCell As Range
Dim myCollection As New Collection
Dim myElement As Variant
Dim sh As Object
Application.ScreenUpdating = False
LR = Cells(Rows.Count, "B").End(xlUp).Row
If LR < 4 Then LR = 4
LCol = Cells(3, Columns.Count).End(xlToLeft).Column
Range(Cells(4, 2), Cells(LR, LCol)).ClearContents
   For iSheet = ThisWorkbook.Worksheets.Count To 2 Step -1
      Sheets(iSheet).Activate
      Set myRange = Range("B3", Range("B" & Rows.Count).End(xlUp))
      On Error Resume Next
         For Each myCell In myRange
            myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
         Next myCell
   Next
 On Error GoTo 0
   i = 4
 For Each myElement In myCollection
   Sheets(1).Cells(i, 2) = myElement
   i = i + 1
 Next
 LR = Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row
     a = 4
     For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Итог" Then
            sh.Activate
            LR1 = sh.Cells(Rows.Count, "B").End(xlUp).Row
              For j2 = 3 To LR1
                 For j = 4 To LR
                    If sh.Cells(j2, 2).Value = Sheets(1).Cells(j, 2) Then
                      Cells(j2, 4).Copy Sheets(1).Cells(j, a)
                      Cells(j2, 3).Copy Sheets(1).Cells(j, 3)
                    End If
                  Next
               Next
            a = a + 1
          End If
     Next
Sheets(1).Activate
Application.ScreenUpdating = True
End Sub

Function SheetList(N As Integer)
    SheetList = ActiveWorkbook.Worksheets(N).Name
End Function
 
casag,Очень даже неплохо работает, столбцы подгружает, предметы добавляет :D
Но вот если добавить еще лист с другим именем, то имя в столбец не пишется и не становится гиперссылкой :cry:  
 
Цитата
Iluxa написал:
имя в столбец не пишется и не становится гиперссылкой
а протяните Е1:Е3 вправо
 
artyrH,да точно не сразу заметил, позже обнаружил) вот пытаюсь привязать и это к кнопке, чтобы копировала свойства, ну тут вроде проблем не должно быть, но что то не нравится постоянно(
Попробую поправить

точнее даже есть один вопрос, не можете подсказать как сделать чтобы он копировал ячейку (кол-во листов -1) раз
Изменено: Iluxa - 23.07.2019 07:43:45
 
Уважаемые форумчане, добрый день!

Попробовал решить данную задачу, используя словарь и массив.
Для заполнения итоговой таблицы пришлось использовать сводную.

Подскажите, пжл, есть ли решение без выгрузки на лист и создания сводной?
Возможно ли заполнить итоговую сразу из массива или словаря?

Спасибо.
 
Нужно легонько мяукнуть  :)
Код
Sub Мяу()
    Dim ar, ar1
    Dim oDic As Object
    Dim i&, j&, n&, x
    n = (Sheets.Count - 1)
    Set oDic = CreateObject("Scripting.Dictionary")
    ReDim ar(n)
    For i = 2 To Sheets.Count
        ar(i - 1) = Sheets(i).Name
    Next
    oDic.Item("names") = ar
    For i = 2 To Sheets.Count
        ar1 = Sheets(i).Range("B1").CurrentRegion.Value
        For j = 2 To UBound(ar1)
            If oDic.exists(ar1(j, 1)) Then
                ar = oDic.Item(ar1(j, 1))
                ar(i - 1) = ar1(j, 3)
                oDic.Item(ar1(j, 1)) = ar
            Else
                ReDim ar(n)
                ar(0) = ar1(j, 1)
                ar(i - 1) = ar1(j, 3)
                oDic.Item(ar1(j, 1)) = ar
            End If
        Next
    Next
    x = oDic.Items
    [N15].Resize(oDic.Count, n + 1).Value = Application.Transpose(Application.Transpose(x))
End Sub
 
RAN, спасибо большое
 
Добрый вечер!
Может кому пригодится. Доработал сборку данных с рабочих листов с помощью словаря.
Использовал классную конструкцию, которую предложил RAN, добавил автоматическое заполнение гиперссылками наименований столбцов итоговой таблицы.
Спасибо.
 
Пример решения с помощью надстройки MergeAndTotals
Изменено: PowerBoy - 18.08.2019 10:51:14
Excel + SQL = Activetables
 
Smurov, это потрясающе! Спасибо!
Страницы: 1
Наверх