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

Вход

Регистрация

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

 

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

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

2010
Всем привет! Сразу оговорюсь, что данную тему поднимал на планете excel? но к сожалению не умею оформлять крос.
Назрел вопрос, который без помощи профи мне не решить.
Есть книга, объединяющая в себе разные счета. В этой книге счета имеют одинаковые столбцы, только количество строк у них постоянно меняется. Помимо счетов имеется лист, с помощью которого формируется заявка на отпуск материалов со склада - вводится номенклатурный номер или он ищется в выпадающем списке. Но есть несколько но:
1. В таблицах счетов есть пустые строки, что создает неудобство при заполнении заявки.
2. У меня получилось к заявке привязать только один лист.
Теперь суть вопроса:
1. Как можно собрать данные, строки выделены цветом, со всех счетов на лист "Обобщенка". В идеале - чтоб при появлении в одном из счетов новых данных, лист со сводной информацией мог обновляться автоматически.
2. Может есть альтернативный способ создания выпадающего списка с разных листов, но без пустых строк.
Спасибо.
К сообщению приложен файл: 9525152.xlsm (61.8 Kb)
 
Ответить
СообщениеВсем привет! Сразу оговорюсь, что данную тему поднимал на планете excel? но к сожалению не умею оформлять крос.
Назрел вопрос, который без помощи профи мне не решить.
Есть книга, объединяющая в себе разные счета. В этой книге счета имеют одинаковые столбцы, только количество строк у них постоянно меняется. Помимо счетов имеется лист, с помощью которого формируется заявка на отпуск материалов со склада - вводится номенклатурный номер или он ищется в выпадающем списке. Но есть несколько но:
1. В таблицах счетов есть пустые строки, что создает неудобство при заполнении заявки.
2. У меня получилось к заявке привязать только один лист.
Теперь суть вопроса:
1. Как можно собрать данные, строки выделены цветом, со всех счетов на лист "Обобщенка". В идеале - чтоб при появлении в одном из счетов новых данных, лист со сводной информацией мог обновляться автоматически.
2. Может есть альтернативный способ создания выпадающего списка с разных листов, но без пустых строк.
Спасибо.

Автор - graffserg
Дата добавления - 09.10.2022 в 00:16
graffserg Дата: Воскресенье, 09.10.2022, 10:51 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 1 ±
Замечаний: 0% ±

2010
Вот, на форуме нашел макрос:
[vba]
Код

Sub Sbor()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:K" & iLastRow).EntireRow.Delete
    For Each Sht In Worksheets
    If Sht.Name <> "Обобщенка" And Sht.Name <> "123" Then
        With Sht
        iLR = .Cells(.Rows.Count, 1).End(xlUp).Row
        iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Range(.Cells(2, "A"), .Cells(iLR, "K")).Copy Cells(iLastRow, 1)
        End With
    End If
    Next
End Sub

[/vba]
Он данные собирает, но:
- сбор данных происходит со всех листов, а мне необходимо именно с листов, которые содержат данные счетов - Лист 1, 2 и 3.
- сбор происходит вместе с пустыми строками, а мне необходимо именно строки, которые выделены цветом, в моем случае светло коричневый.
Спасибо.
 
Ответить
СообщениеВот, на форуме нашел макрос:
[vba]
Код

Sub Sbor()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:K" & iLastRow).EntireRow.Delete
    For Each Sht In Worksheets
    If Sht.Name <> "Обобщенка" And Sht.Name <> "123" Then
        With Sht
        iLR = .Cells(.Rows.Count, 1).End(xlUp).Row
        iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Range(.Cells(2, "A"), .Cells(iLR, "K")).Copy Cells(iLastRow, 1)
        End With
    End If
    Next
End Sub

[/vba]
Он данные собирает, но:
- сбор данных происходит со всех листов, а мне необходимо именно с листов, которые содержат данные счетов - Лист 1, 2 и 3.
- сбор происходит вместе с пустыми строками, а мне необходимо именно строки, которые выделены цветом, в моем случае светло коричневый.
Спасибо.

Автор - graffserg
Дата добавления - 09.10.2022 в 10:51
graffserg Дата: Воскресенье, 09.10.2022, 22:05 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 1 ±
Замечаний: 0% ±

2010
Уважаемые профи, реально нужна Ваша помощь.
Вот, есть макрос:
[vba]
Код
Sub MacroCollector()
Dim LastRow As Long, i As Long, n As Long, Arr, Uniq As New Collection, x As Long, Material
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 1)).Clear
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    On Error Resume Next
                    If .Cells(i, 1).Interior.ColorIndex = 40 Then Uniq.Add .Cells(i, 2), CStr(.Cells(i, 2))
                Next
            End If
        End With
    Next
    ReDim Arr(1 To Uniq.Count, 1 To 1)
    For Each Material In Uniq
        x = x + 1
        Arr(x, 1) = Material
    Next
    Range("A2").Resize(x, 1).Value = Arr
    Application.ScreenUpdating = True
End Sub
[/vba]
То, что нужно, как мне кажется, но:
1. сбор данных происходит только по 2 столбцу счетов, а мне нужны столбцы 2, 3, 4 (наименование, код и единица измерения).
2. при сборе данных удаляются дубликаты, которые имеются в счетах, а мне необходимо сбор всех данных, так как идентификатором является инвентарный номер.
3. как сбор данных поместитесь в "умную таблицу" - это для того, чтобы был динамический диапазон для выпадающего списка.
 
Ответить
СообщениеУважаемые профи, реально нужна Ваша помощь.
Вот, есть макрос:
[vba]
Код
Sub MacroCollector()
Dim LastRow As Long, i As Long, n As Long, Arr, Uniq As New Collection, x As Long, Material
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 1)).Clear
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    On Error Resume Next
                    If .Cells(i, 1).Interior.ColorIndex = 40 Then Uniq.Add .Cells(i, 2), CStr(.Cells(i, 2))
                Next
            End If
        End With
    Next
    ReDim Arr(1 To Uniq.Count, 1 To 1)
    For Each Material In Uniq
        x = x + 1
        Arr(x, 1) = Material
    Next
    Range("A2").Resize(x, 1).Value = Arr
    Application.ScreenUpdating = True
End Sub
[/vba]
То, что нужно, как мне кажется, но:
1. сбор данных происходит только по 2 столбцу счетов, а мне нужны столбцы 2, 3, 4 (наименование, код и единица измерения).
2. при сборе данных удаляются дубликаты, которые имеются в счетах, а мне необходимо сбор всех данных, так как идентификатором является инвентарный номер.
3. как сбор данных поместитесь в "умную таблицу" - это для того, чтобы был динамический диапазон для выпадающего списка.

Автор - graffserg
Дата добавления - 09.10.2022 в 22:05
msi2102 Дата: Понедельник, 10.10.2022, 09:07 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
сбор данных происходит со всех листов, а мне необходимо именно с листов, которые содержат данные счетов - Лист 1, 2 и 3
У Вас это реальные названия (Лист 1, Лист 2, Лист 3) или Вам нужно исключить определенные листы из обработки, или наоборот, чтобы обрабатывались только определенные листы. Попробуйте запустить макрос ниже, для понимания
[vba]
Код
Sub Листы()
Dim Sht As Worksheet
    For Each Sht In Worksheets
        If Sht.Name <> "Обобщенка" And Sht.Name <> "Заявка" And Sht.Name <> "Данные" Then
            MsgBox Sht.Name
        End If
    Next
End Sub
[/vba]
сбор происходит вместе с пустыми строками, а мне необходимо именно строки, которые выделены цветом, в моем случае светло коричневый

Между выделенными строками (наименование) существуют ещё строки с данными, они тоже должны копироваться, или должна копироваться только первая строка, что делать с остальными данными? Должны копироваться значения или формулы? Покажите в примере как должен выглядеть результат.
как сбор данных поместитесь в "умную таблицу" - это для того, чтобы был динамический диапазон для выпадающего списка.

Про умные таблицы почитайте ТУТ или ТУТ
А если Вам нужно собрать все листы в умную, то возможно Вам лучше обратить внимание на PQ, почитайте ТУТ
[p.s.]ТУТ похожая тема


Сообщение отредактировал msi2102 - Понедельник, 10.10.2022, 09:37
 
Ответить
Сообщение
сбор данных происходит со всех листов, а мне необходимо именно с листов, которые содержат данные счетов - Лист 1, 2 и 3
У Вас это реальные названия (Лист 1, Лист 2, Лист 3) или Вам нужно исключить определенные листы из обработки, или наоборот, чтобы обрабатывались только определенные листы. Попробуйте запустить макрос ниже, для понимания
[vba]
Код
Sub Листы()
Dim Sht As Worksheet
    For Each Sht In Worksheets
        If Sht.Name <> "Обобщенка" And Sht.Name <> "Заявка" And Sht.Name <> "Данные" Then
            MsgBox Sht.Name
        End If
    Next
End Sub
[/vba]
сбор происходит вместе с пустыми строками, а мне необходимо именно строки, которые выделены цветом, в моем случае светло коричневый

Между выделенными строками (наименование) существуют ещё строки с данными, они тоже должны копироваться, или должна копироваться только первая строка, что делать с остальными данными? Должны копироваться значения или формулы? Покажите в примере как должен выглядеть результат.
как сбор данных поместитесь в "умную таблицу" - это для того, чтобы был динамический диапазон для выпадающего списка.

Про умные таблицы почитайте ТУТ или ТУТ
А если Вам нужно собрать все листы в умную, то возможно Вам лучше обратить внимание на PQ, почитайте ТУТ
[p.s.]ТУТ похожая тема

Автор - msi2102
Дата добавления - 10.10.2022 в 09:07
graffserg Дата: Понедельник, 10.10.2022, 18:17 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 1 ±
Замечаний: 0% ±

2010
Решение найдено! Спасибо МатросНаЗебре с сайта Планета Excel
[vba]
Код
Sub MacroCollector()
    Dim LastRow As Long, i As Long, n As Long, arr As Variant, Uniq As New Collection, x As Long, Material As Variant
    Dim yy As Long
    Dim xx As Long
    Application.ScreenUpdating = False
    Dim rr As Range
    On Error Resume Next
    Set rr = ActiveSheet.ListObjects(1).DataBodyRange
    On Error GoTo 0
    If rr Is Nothing Then
        Set rr = Cells(5, 1)
    Else
        ActiveSheet.ListObjects(1).Resize ActiveSheet.ListObjects(1).Range.Rows(1).Resize(2)
    End If
      
    LastRow = Cells(Rows.Count, rr.Column).End(xlUp).Row
    Range(Cells(rr.Row, rr.Column), Cells(LastRow + 1, rr.Column)).EntireRow.ClearContents
    yy = rr.Row
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    If Not IsEmpty(.Cells(i, 2).Value) Then
                        If .Cells(i, 1).Interior.ColorIndex = 40 Then
                            arr = .Cells(i, 1).Resize(1, .UsedRange.Columns.Count - 1)
                            Cells(yy, rr.Column).Resize(1, UBound(arr, 2)).Value = arr
'                            For xx = 2 To 4
'                    Cells(yy, rr.Column + xx - 2).Value = .Cells(i, xx)
'                            Next
                            yy = yy + 1
                        End If
                    End If
                Next
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
СообщениеРешение найдено! Спасибо МатросНаЗебре с сайта Планета Excel
[vba]
Код
Sub MacroCollector()
    Dim LastRow As Long, i As Long, n As Long, arr As Variant, Uniq As New Collection, x As Long, Material As Variant
    Dim yy As Long
    Dim xx As Long
    Application.ScreenUpdating = False
    Dim rr As Range
    On Error Resume Next
    Set rr = ActiveSheet.ListObjects(1).DataBodyRange
    On Error GoTo 0
    If rr Is Nothing Then
        Set rr = Cells(5, 1)
    Else
        ActiveSheet.ListObjects(1).Resize ActiveSheet.ListObjects(1).Range.Rows(1).Resize(2)
    End If
      
    LastRow = Cells(Rows.Count, rr.Column).End(xlUp).Row
    Range(Cells(rr.Row, rr.Column), Cells(LastRow + 1, rr.Column)).EntireRow.ClearContents
    yy = rr.Row
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    If Not IsEmpty(.Cells(i, 2).Value) Then
                        If .Cells(i, 1).Interior.ColorIndex = 40 Then
                            arr = .Cells(i, 1).Resize(1, .UsedRange.Columns.Count - 1)
                            Cells(yy, rr.Column).Resize(1, UBound(arr, 2)).Value = arr
'                            For xx = 2 To 4
'                    Cells(yy, rr.Column + xx - 2).Value = .Cells(i, xx)
'                            Next
                            yy = yy + 1
                        End If
                    End If
                Next
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub
[/vba]

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

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