Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сбор данных с нескольких листов на один
 
#1
08.10.2022 23:48:34
Всем привет!
Назрел вопрос, который без помощи профи мне не решить.
Есть книга, объединяющая в себе разные счета. В этой книге счета имеют одинаковые столбцы, только количество строк у них постоянно меняется. Помимо счетов имеется лист, с помощью которого формируется заявка на отпуск материалов со склада - вводится номенклатурный номер или он ищется в выпадающем списке. Но есть несколько но:
1. В таблицах счетов есть пустые строки, что создает неудобство при заполнении заявки.
2. У меня получилось к заявке привязать только один лист.
Теперь суть вопроса:
1. Как можно собрать данные, строки выделены цветом, со всех счетов на лист "Обобщенка". В идеале - чтоб при появлении в одном из счетов новых данных, лист со сводной информацией мог обновляться автоматически.
2. Может есть альтернативный способ создания выпадающего списка с разных листов, но без пустых строк.
Спасибо.
Изменено: graffserg - 08.10.2022 23:49:11
 
 
 
#2
09.10.2022 10:51:55
Вот, на форуме нашел макрос:
Код
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

Он данные собирает, но:
- сбор данных происходит со всех листов, а мне необходимо именно с листов, которые содержат данные счетов - Лист 1, 2 и 3.
- сбор происходит вместе с пустыми строками, а мне необходимо именно строки, которые выделены цветом, в моем случае светло коричневый.
Изменено: graffserg - 09.10.2022 10:52:39
 
 
 
#3
09.10.2022 22:04:59
Уважаемые профи, реально нужна Ваша помощь.
Вот, есть макрос:
Код
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

То, что нужно, как мне кажется, но:
1. сбор данных происходит только по 2 столбцу счетов, а мне нужны столбцы 2, 3, 4 (наименование, код и единица измерения).
2. при сборе данных удаляются дубликаты, которые имеются в счетах, а мне необходимо сбор всех данных, так как идентификатором является инвентарный номер.
3. как сбор данных поместитесь в "умную таблицу" - это для того, чтобы был динамический диапазон для выпадающего списка.
 
 
 
#4
10.10.2022 11:22:06
Код
Sub MacroCollector()
    Dim LastRow As Long, i As Long, n As Long, Arr, Uniq As New Collection, x As Long, Material As Variant
    Dim yy As Long
    Dim xx As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 1)).Clear
    yy = 2
    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
                        For xx = 2 To 4
                            Cells(yy, xx - 1).Value = .Cells(i, xx)
                        Next
                        yy = yy + 1
                    End If
                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
Так себе идея, спросить про макрос в ветке, к которой прикреплён файл по другому вопросу.
 
 
 
#5
10.10.2022 11:51:02
Кросс http://www.excelworld.ru/forum/10-50657-1
 
 
 
#6
10.10.2022 11:55:50
Цитата
МатросНаЗебре написал:
Так себе идея, спросить про макрос в ветке, к которой прикреплён файл по другому вопросу.
Немного не понял Ваш ответ, но макрос работает.
Если можно, то помогите подправить макрос так, чтобы:
- выбранные данные добавлялись в "умную таблицу";
- выбранные данные не разделялись пустой строкой, а шли нарастающим порядком.
Спасибо.
 
 
 
#7
10.10.2022 12:20:08
Цитата
написал:
Немного не понял Ваш ответ, но макрос работает.
Приложите пример. Предыдущий ответ был попыткой угадать, что представляет из себя файл, по всей видимости, удачной ).
 
 
 
#8
10.10.2022 12:28:54
Цитата
МатросНаЗебре написал:
Цитата
написал:
Немного не понял Ваш ответ, но макрос работает.
Приложите пример. Предыдущий ответ был попыткой угадать, что представляет из себя файл, по всей видимости, удачной ).
 
 
 
#9
10.10.2022 12:36:29
graffserg,   размещаете вопрос на нескольких ресурсах - информируйте об жтом прямыми ссылками. И не увлекайтесь цитированием.
 
 
 
#10
10.10.2022 12:56:45
А, так это и был пример. Тогда в какую умную таблицу нужно добавлять?
Код
Sub MacroCollector()
    Dim LastRow As Long, i As Long, n As Long, Arr, Uniq As New Collection, x As Long, Material As Variant
    Dim yy As Long
    Dim xx As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 3)).Clear
    yy = 2
    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
                            For xx = 2 To 4
                                Cells(yy, xx - 1).Value = .Cells(i, xx)
                            Next
                            yy = yy + 1
                        End If
                    End If
                Next
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub
 
 
 
#11
10.10.2022 13:09:24
Код
Sub MacroCollector()
    Dim LastRow As Long, i As Long, n As Long, Arr, 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(2, 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 + 2)).Clear
    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
                            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
 
 
 
#12
10.10.2022 15:33:19
МатросНаЗебре, еще раз спасибо за помощь. Макрос работает.
Насчет "умной таблицы"- я имею ввиду, чтобы данные собранные со счетов на лист "Обобщенка" формировались в "умную таблицу".
Объясню почему - дело в том, что в последующем я хочу на базе собранных данных создать выпадающий список на листе "Заявка", которую и буду заполнять по средствам формулы ИНДЕКС и ПОИСКПОЗ.
 
 
 
#13
10.10.2022 15:43:00
Цитата
graffserg написал:
я хочу на базе собранных данных создать выпадающий список
А для этого ОБЯЗАТЕЛЬНО умная таблица нужна?
 
 
 
#14
10.10.2022 16:03:16
Я как бы не спрашивал, зачем Вам нужна умная таблица. Я спрашивал, в какую умную таблицу вносить данные.
Вариант в сообщении #11 добавляет в первую умную таблицу на активном листе.
 
 
 
#15
10.10.2022 16:21:52
Цитата
Юрий М написал:
А для этого ОБЯЗАТЕЛЬНО умная таблица нужна?
Юрий М, на данный момент это единственно решение, до которого я додумался.
Я еще хотел попробовать данные с листов подтягивать с помощь формулы:
Код
=ЕСЛИ(ЕПУСТО(Заявка!$C5);"";ИНДЕКС(Таблица1[2];ПОИСКПОЗ(Заявка!$C5;Таблица1[3];0)))
,
но у меня пока получается только с одного листа.

Цитата
МатросНаЗебре написал:
Я спрашивал, в какую умную таблицу вносить данные.
МатросНаЗебре спасибо, работает.
А можно еще попросить о помощи подправить макрос:
- чтобы строки копировались полностью, своего рода повторяли структуру таблиц с листов со счетами;
- чтобы при изменении данных на листах со счетами, они автоматически добавлялись на лист "Обобщенка".

Спасибо.
Изменено: graffserg - 10.10.2022 16:27:34
 
 
 
#16
10.10.2022 16:45:43
Цитата
написал:
чтобы строки копировались полность
Код
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(2, 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 + 2)).Clear
    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, 2).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

Цитата
написал:
чтобы при изменении данных на листах со счетами, они автоматически добавлялись на лист "Обобщенка"
Это уже совсем другая история.
 
 
 
#17
10.10.2022 17:04:14
Уважаемый МатросНаЗебре, еще раз спасибо за оказанную помощь.
Уделите пожалуйста еще немного Вашего драгоценного времени и помогите, если не затруднит, "причесать" макрос:
- создал умную таблицу по образцу и при запуске макроса в строке
Код
Range(Cells(rr.Row, rr.Column), Cells(LastRow + 1, rr.Column + 2)).Clear

возникает ошибка.
- если удалить строки с 1 по 3, то макрос срабатывает, но строки копируются не полностью;
- и самое главное:
Цитата
МатросНаЗебре написал:
Это уже совсем другая история
дабы не создавать кучу тем, помогите автоматизировать процесс сбора данных.
Честно, в макросах не силен и подправить его самостоятельно не смогу.
Спасибо.
 
 
 
#18
10.10.2022 17:27:45
Это должно помочь.
Код
Range(Cells(rr.Row, rr.Column), Cells(LastRow + 1, rr.Column)).EntireRow.ClearContents
Цитата
написал:
дабы не создавать кучу тем
На другой вопрос придётся создать другую тему. Можете поспорить на эту тему с модераторами )
 
 
 
#19
10.10.2022 17:35:53
Спасибо еще раз, но увы
Код
Range(Cells(rr.Row, rr.Column), Cells(LastRow + 1, rr.Column)).EntireRow.ClearContents

макрос выдает ошибку.
Вы могли бы глянуть прикрепленный файл?
 
 
 
#20
10.10.2022 17:41:34
Код
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
 
 
 
#21
10.10.2022 17:59:06
Спасибо! Работает все на ура! Буду тестить.
 
 
 
Страницы: 1
Наверх