Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/вывод данных из нескольких листов на один лист по шаблону - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » вывод данных из нескольких листов на один лист по шаблону (Макросы/Sub)
вывод данных из нескольких листов на один лист по шаблону
udjin Дата: Понедельник, 15.01.2024, 16:32 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 40% ±

2016
Добрый день, есть журнал учеников, каждый класс на отдельном листе, задача состоит в том чтобы вывести данные всех классов на один лист согласно шаблону, и если количество учеников изменится в классах нужно чтобы классы были по порядку без пустых строк. Пример во вложении.
К сообщению приложен файл: klass.xlsx (15.2 Kb)


udjin
 
Ответить
СообщениеДобрый день, есть журнал учеников, каждый класс на отдельном листе, задача состоит в том чтобы вывести данные всех классов на один лист согласно шаблону, и если количество учеников изменится в классах нужно чтобы классы были по порядку без пустых строк. Пример во вложении.

Автор - udjin
Дата добавления - 15.01.2024 в 16:32
jun Дата: Понедельник, 15.01.2024, 18:10 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Добрый день!
Вариант (запускать по Alt+F8, результат на листе с именем Шаблон) :
[vba]
Код
Sub pupils()
Dim sh As Worksheet, lr As Long, LastRow As Long, pupilsCount As Integer, pupilsRange As Range
Dim AppScrUpd
AppScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

LastRow = 1
ThisWorkbook.Worksheets("Шаблон").Cells.Clear
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "Шаблон" Then
        With sh
            lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set pupilsRange = .Range("A2:B" & lr)
            pupilsCount = lr - 1
            With ThisWorkbook.Worksheets("Шаблон")
                .Cells(LastRow, 1) = sh.Name & " ----> " & pupilsCount & " учеников"
                .Cells(LastRow, 1).Interior.Color = 4697456
                With .Range(.Cells(LastRow, 1), .Cells(LastRow, 9))
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                pupilsRange.Copy .Cells(LastRow + 1, 1)
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                
            End With
        End With
    End If
Next sh
Application.ScreenUpdating = AppScrUpd
End Sub
[/vba]
К сообщению приложен файл: klass.xlsb (21.5 Kb)
 
Ответить
СообщениеДобрый день!
Вариант (запускать по Alt+F8, результат на листе с именем Шаблон) :
[vba]
Код
Sub pupils()
Dim sh As Worksheet, lr As Long, LastRow As Long, pupilsCount As Integer, pupilsRange As Range
Dim AppScrUpd
AppScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

LastRow = 1
ThisWorkbook.Worksheets("Шаблон").Cells.Clear
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "Шаблон" Then
        With sh
            lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set pupilsRange = .Range("A2:B" & lr)
            pupilsCount = lr - 1
            With ThisWorkbook.Worksheets("Шаблон")
                .Cells(LastRow, 1) = sh.Name & " ----> " & pupilsCount & " учеников"
                .Cells(LastRow, 1).Interior.Color = 4697456
                With .Range(.Cells(LastRow, 1), .Cells(LastRow, 9))
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                pupilsRange.Copy .Cells(LastRow + 1, 1)
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                
            End With
        End With
    End If
Next sh
Application.ScreenUpdating = AppScrUpd
End Sub
[/vba]

Автор - jun
Дата добавления - 15.01.2024 в 18:10
jun Дата: Понедельник, 15.01.2024, 18:50 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

добавил второй вариант с сортировкой учеников и произвольным порядком листов:
[vba]
Код
Sub pupils()
Dim sh As Worksheet, lr As Long, LastRow As Long, pupilsCount As Integer, pupilsRange As Range
Dim AppScrUpd, j As Integer, arr(), shName, pupilsArray
j = 1
With ThisWorkbook
    For Each sh In .Worksheets
        If RegexExtract(sh.Name) Then
            If sh.Name <> "Шаблон" Then ReDim Preserve arr(1 To j): arr(j) = sh.Name: j = j + 1
        End If
    Next sh
End With

arr = sort_arr(arr)

AppScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

LastRow = 1
ThisWorkbook.Worksheets("Шаблон").Cells.Clear
For Each shName In arr
    With ThisWorkbook.Worksheets(shName)
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        pupilsArray = .Range("A2:B" & lr)
        pupilsArray = sort_pupil(pupilsArray)
        pupilsCount = lr - 1
        With ThisWorkbook.Worksheets("Шаблон")
            .Cells(LastRow, 1) = shName & " ----> " & pupilsCount & " учеников"
            .Cells(LastRow, 1).Interior.Color = 4697456
            With .Range(.Cells(LastRow, 1), .Cells(LastRow, 9))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            .Cells(LastRow + 1, 1).Resize(UBound(pupilsArray, 1), UBound(pupilsArray, 2)) = pupilsArray
            LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
    End With
Next shName
Application.ScreenUpdating = AppScrUpd
End Sub
Private Function sort_arr(arr) As Variant
Dim i, j, tmp
    For i = LBound(arr) To UBound(arr)
        For j = i To UBound(arr)
            If arr(i) > arr(j) Then
                tmp = arr(j)
                arr(j) = arr(i)
                arr(i) = tmp
            End If
        Next j
    Next i
    sort_arr = arr
End Function
Private Function sort_pupil(arr) As Variant
Dim i, j, tmp
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = i To UBound(arr, 1)
            If arr(i, 2) > arr(j, 2) Then
                tmp = arr(j, 2)
                arr(j, 2) = arr(i, 2)
                arr(i, 2) = tmp
            End If
        Next j
    Next i
    sort_pupil = arr
End Function
Private Function RegexExtract(s As String) As Boolean
RegexExtract = False
With CreateObject("VBScript.Regexp")
    .Global = False: .MultiLine = False: .Pattern = "^\d[0-2]?[А-Жа-ж]$"
    If .test(s) Then RegexExtract = True: Exit Function
End With
End Function
[/vba]
К сообщению приложен файл: klass_shuffle_with_sort.xlsb (25.6 Kb)
 
Ответить
Сообщениедобавил второй вариант с сортировкой учеников и произвольным порядком листов:
[vba]
Код
Sub pupils()
Dim sh As Worksheet, lr As Long, LastRow As Long, pupilsCount As Integer, pupilsRange As Range
Dim AppScrUpd, j As Integer, arr(), shName, pupilsArray
j = 1
With ThisWorkbook
    For Each sh In .Worksheets
        If RegexExtract(sh.Name) Then
            If sh.Name <> "Шаблон" Then ReDim Preserve arr(1 To j): arr(j) = sh.Name: j = j + 1
        End If
    Next sh
End With

arr = sort_arr(arr)

AppScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

LastRow = 1
ThisWorkbook.Worksheets("Шаблон").Cells.Clear
For Each shName In arr
    With ThisWorkbook.Worksheets(shName)
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        pupilsArray = .Range("A2:B" & lr)
        pupilsArray = sort_pupil(pupilsArray)
        pupilsCount = lr - 1
        With ThisWorkbook.Worksheets("Шаблон")
            .Cells(LastRow, 1) = shName & " ----> " & pupilsCount & " учеников"
            .Cells(LastRow, 1).Interior.Color = 4697456
            With .Range(.Cells(LastRow, 1), .Cells(LastRow, 9))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            .Cells(LastRow + 1, 1).Resize(UBound(pupilsArray, 1), UBound(pupilsArray, 2)) = pupilsArray
            LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
    End With
Next shName
Application.ScreenUpdating = AppScrUpd
End Sub
Private Function sort_arr(arr) As Variant
Dim i, j, tmp
    For i = LBound(arr) To UBound(arr)
        For j = i To UBound(arr)
            If arr(i) > arr(j) Then
                tmp = arr(j)
                arr(j) = arr(i)
                arr(i) = tmp
            End If
        Next j
    Next i
    sort_arr = arr
End Function
Private Function sort_pupil(arr) As Variant
Dim i, j, tmp
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = i To UBound(arr, 1)
            If arr(i, 2) > arr(j, 2) Then
                tmp = arr(j, 2)
                arr(j, 2) = arr(i, 2)
                arr(i, 2) = tmp
            End If
        Next j
    Next i
    sort_pupil = arr
End Function
Private Function RegexExtract(s As String) As Boolean
RegexExtract = False
With CreateObject("VBScript.Regexp")
    .Global = False: .MultiLine = False: .Pattern = "^\d[0-2]?[А-Жа-ж]$"
    If .test(s) Then RegexExtract = True: Exit Function
End With
End Function
[/vba]

Автор - jun
Дата добавления - 15.01.2024 в 18:50
udjin Дата: Вторник, 16.01.2024, 13:11 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 40% ±

2016
Благодарю, второй вариант вообще бомба) hands но первый больше подходит тем что нет привязки к именам листов, подскажите если в книге будут еще листы которые не должны попасть в шаблон, куда прописать их в коде чтобы они не участвовали в макросе.


udjin
 
Ответить
СообщениеБлагодарю, второй вариант вообще бомба) hands но первый больше подходит тем что нет привязки к именам листов, подскажите если в книге будут еще листы которые не должны попасть в шаблон, куда прописать их в коде чтобы они не участвовали в макросе.

Автор - udjin
Дата добавления - 16.01.2024 в 13:11
jun Дата: Вторник, 16.01.2024, 14:19 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Второй вариант подразумевает названия листов по имени класса - 1А, 4Б, 11В, и так далее (используются буквы от А до Ж).
Если будете использовать первый вариант, то названия листов, которые нужно исключить нужно дописать в строку:
[vba]
Код
If sh.Name <> "Шаблон" Then
[/vba] в цикле, через оператор and. То есть:
[vba]
Код
If sh.Name <> "Шаблон" and sh.Name <> "имя1" and sh.Name <> "имя2" Then
[/vba]

Но я бы сделал на каждый класс отдельный лист и пользовался макросом из второго варианта


Сообщение отредактировал jun - Вторник, 16.01.2024, 15:50
 
Ответить
СообщениеВторой вариант подразумевает названия листов по имени класса - 1А, 4Б, 11В, и так далее (используются буквы от А до Ж).
Если будете использовать первый вариант, то названия листов, которые нужно исключить нужно дописать в строку:
[vba]
Код
If sh.Name <> "Шаблон" Then
[/vba] в цикле, через оператор and. То есть:
[vba]
Код
If sh.Name <> "Шаблон" and sh.Name <> "имя1" and sh.Name <> "имя2" Then
[/vba]

Но я бы сделал на каждый класс отдельный лист и пользовался макросом из второго варианта

Автор - jun
Дата добавления - 16.01.2024 в 14:19
udjin Дата: Вторник, 16.01.2024, 17:32 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 40% ±

2016
clap а я через ";" пробовал в цикле указать имена книг и соответственно получал ошибку) теперь буду знать про "and" и еще задача чтобы получившееся таблица копировалась на лист "Отчет" с определенной строки в данном примере с 8 строки и если не сложно разбивалась по столбцам. Изначально я так понимаю на листе "Шаблон" этого сделать нельзя потому что после выполнения макроса лист обновляется.
К сообщению приложен файл: klass.xlsm (29.9 Kb)


udjin
 
Ответить
Сообщениеclap а я через ";" пробовал в цикле указать имена книг и соответственно получал ошибку) теперь буду знать про "and" и еще задача чтобы получившееся таблица копировалась на лист "Отчет" с определенной строки в данном примере с 8 строки и если не сложно разбивалась по столбцам. Изначально я так понимаю на листе "Шаблон" этого сделать нельзя потому что после выполнения макроса лист обновляется.

Автор - udjin
Дата добавления - 16.01.2024 в 17:32
jun Дата: Вторник, 16.01.2024, 18:07 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

проверяйте
К сообщению приложен файл: klass_v2_0.xlsb (18.4 Kb)
 
Ответить
Сообщениепроверяйте

Автор - jun
Дата добавления - 16.01.2024 в 18:07
udjin Дата: Четверг, 18.01.2024, 18:25 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 40% ±

2016
Сегодня проверил, получается если добавить лист или увеличить или уменьшить количество учеников то ломается вся структура, наверное проще тогда как в первом варианте каждый класс идет под следующим, только вот не могу слепить из двух вариантов чтобы оставалась шапка и изменялись данные.


udjin
 
Ответить
СообщениеСегодня проверил, получается если добавить лист или увеличить или уменьшить количество учеников то ломается вся структура, наверное проще тогда как в первом варианте каждый класс идет под следующим, только вот не могу слепить из двух вариантов чтобы оставалась шапка и изменялись данные.

Автор - udjin
Дата добавления - 18.01.2024 в 18:25
jun Дата: Четверг, 18.01.2024, 20:12 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Наверное я ошибся в коде. Писал вечером уже.
Можно Вас попросить описать задачу максимально подробно и приложить файл, с тем что хотите получить.
не могу слепить из двух вариантов

Можно Вас попросить пояснить этот момент?
Спасибо!
 
Ответить
СообщениеНаверное я ошибся в коде. Писал вечером уже.
Можно Вас попросить описать задачу максимально подробно и приложить файл, с тем что хотите получить.
не могу слепить из двух вариантов

Можно Вас попросить пояснить этот момент?
Спасибо!

Автор - jun
Дата добавления - 18.01.2024 в 20:12
jun Дата: Четверг, 18.01.2024, 21:15 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Если правильно понял, то (см. файл)
Доработал код из своего первого ответа. Тестируйте.
Подразумевается, что в книге будут только листы с именами классов (1А, 4Б, 11В, и т.д.). И листы с именами Шаблон и ОТЧЕТ, или один, с именем ОТЧЕТ
Также при каждом запуске макроса, перед копированием данных на лист ОТЧЕТ, строки, начиная с 8 и ниже очищаются и затем данные с листов, с именами классов копируются, начиная с 8 строки
обновление файла 19.01: нашел ошибку в коде и исправил. Корректный макрос от 19.01
К сообщению приложен файл: 0458916.xlsb (28.9 Kb)


Сообщение отредактировал jun - Пятница, 19.01.2024, 09:48
 
Ответить
СообщениеЕсли правильно понял, то (см. файл)
Доработал код из своего первого ответа. Тестируйте.
Подразумевается, что в книге будут только листы с именами классов (1А, 4Б, 11В, и т.д.). И листы с именами Шаблон и ОТЧЕТ, или один, с именем ОТЧЕТ
Также при каждом запуске макроса, перед копированием данных на лист ОТЧЕТ, строки, начиная с 8 и ниже очищаются и затем данные с листов, с именами классов копируются, начиная с 8 строки
обновление файла 19.01: нашел ошибку в коде и исправил. Корректный макрос от 19.01

Автор - jun
Дата добавления - 18.01.2024 в 21:15
udjin Дата: Пятница, 19.01.2024, 20:53 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 40% ±

2016
Благодарю, теперь рисует красивую табличку и привязки нет к названиям листов, буду экспериментировать)


udjin
 
Ответить
СообщениеБлагодарю, теперь рисует красивую табличку и привязки нет к названиям листов, буду экспериментировать)

Автор - udjin
Дата добавления - 19.01.2024 в 20:53
udjin Дата: Среда, 24.01.2024, 22:32 | Сообщение № 12
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 40% ±

2016
во время экспериментов возник вопрос как можно указать что бы таблица строились не с первого столбца а со второго, как в примере, чтобы построение в отчете начиналось со столбца "B"
К сообщению приложен файл: klasssssss.xlsm (28.1 Kb)


udjin
 
Ответить
Сообщениево время экспериментов возник вопрос как можно указать что бы таблица строились не с первого столбца а со второго, как в примере, чтобы построение в отчете начиналось со столбца "B"

Автор - udjin
Дата добавления - 24.01.2024 в 22:32
jun Дата: Суббота, 27.01.2024, 09:36 | Сообщение № 13
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Подправил, проверяйте. :)
К сообщению приложен файл: klass_v3_1.xlsb (32.9 Kb)


Сообщение отредактировал jun - Суббота, 27.01.2024, 10:07
 
Ответить
СообщениеПодправил, проверяйте. :)

Автор - jun
Дата добавления - 27.01.2024 в 09:36
jun Дата: Понедельник, 29.01.2024, 16:18 | Сообщение № 14
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Подправил сортировку в файле. Исправил код
Но код привязан к именам листов. Не знаю, недостаток это или нет. Подразумевается, что имена классов состоят из 1-2 цифр в начале и заканчиваются 1 буквой
К сообщению приложен файл: 8739322.xlsb (33.3 Kb)


Сообщение отредактировал jun - Понедельник, 29.01.2024, 17:41
 
Ответить
СообщениеПодправил сортировку в файле. Исправил код
Но код привязан к именам листов. Не знаю, недостаток это или нет. Подразумевается, что имена классов состоят из 1-2 цифр в начале и заканчиваются 1 буквой

Автор - jun
Дата добавления - 29.01.2024 в 16:18
jun Дата: Понедельник, 29.01.2024, 17:39 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

либо вариант без привязки к именам листов с сортировкой учеников
К сообщению приложен файл: klass_v3_2.xlsb (32.7 Kb)
 
Ответить
Сообщениелибо вариант без привязки к именам листов с сортировкой учеников

Автор - jun
Дата добавления - 29.01.2024 в 17:39
Мир MS Excel » Вопросы и решения » Вопросы по VBA » вывод данных из нескольких листов на один лист по шаблону (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!