Страницы: 1
RSS
Поиск в столбце уникальных номеров документов, создание одноименных листов и перенос на них данных
 
Добрый день, уважаемые Форумчане.

К сожалению, поиск мне не не помог в решении моего вопроса, поэтому вынужден обратиться к Вам за помощью.

Задача: сформировать макрос, который будет обрабатывать таблицу с дальнейшим созданием отдельного документа с данными из этой таблицы и сохранением его на жесткий диск с определенным именем.

Во вложении Вы можете найти таблицу с заготовкой того как я вижу этот процесс на выходе. Т.е. необходимо создать макрос который будет анализировать столбец "Номер строки" и выделять от туда все повторные значения. Каждое повторное значение - это номер документа который должен содержать разные значения находящиеся в разных строках, относящиеся к данному номеру документу. После анализа, макрос создает новый лист с наименованием равным повторяющемуся значению, в котором заполняет в определенных ячейках указывает полученные данные.

Вопрос:
Как выглядит кусок кода который анализирует столбец "Номер строки" выделяет от туда все повторные значения и транслирует значения из соответствующих строк в другой лист?
 
Цитата
Как выглядит кусок кода который анализирует столбец "Номер строки" выделяет от туда все повторные значения
Код
Sub ww()
   Range("A1:A14").AdvancedFilter xlFilterCopy, , Range("I1"), True
   Range("I1") = "Уникальные"
End Sub

В столбце I будут уникальные значения
 
Предложите название темы, отражающее конкретную задачу. Заменят модераторы
 
Kuzmich,
Спасибо! думаю этого будет достаточно.
 
Тема: Поиск в столбце уникальных номеров документов, создание одноименных листов и перенос на них данных
Оставьте в книге только один Лист1 и запустите макрос
Код
Sub ww()
Dim iLastRow As Long
Dim i As Long
Dim n As Integer     'количество позиций
Dim FoundNomer As Range
Dim FAdr As String
Dim Mesto As String
Dim List1 As Worksheet
    Set List1 = ThisWorkbook.Worksheets("Лист1")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Columns("I").ClearContents
  Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, , Range("I1"), True
  Range("I1") = "Уникальные"
  iLastRow = Cells(Rows.Count, "I").End(xlUp).Row
   For i = 2 To iLastRow
     Worksheets.Add After:=Worksheets(Worksheets.Count)    'добавляем лист
     With List1
       ActiveSheet.Name = .Cells(i, "I")                    'присваиваем имя номера
         n = 0
         Mesto = ""
       Set FoundNomer = .Columns(1).Find(.Cells(i, "I"), , xlValues, xlWhole)
        FAdr = FoundNomer.Address
        Do
          n = n + 1
          Mesto = Mesto & .Cells(FoundNomer.Row, "B") & "(" & .Cells(FoundNomer.Row, "E") & "*" & _
                .Cells(FoundNomer.Row, "F") & "*" & .Cells(FoundNomer.Row, "G") & "*" & " м), "
          Set FoundNomer = .Columns(1).FindNext(FoundNomer)
        Loop While FoundNomer.Address <> FAdr
        Range("A1") = "Номер"
        Range("A2") = "Общее количество"
        Range("A3") = "Перечисление мест"
        Range("B1") = ActiveSheet.Name
        Range("B2") = n
        Range("B3") = Left(Mesto, Len(Mesto) - 2)
        Columns("A:B").AutoFit
     End With
       List1.Activate
   Next
End Sub
 
Алексей Капитанов, почему не Вы, а помогающий реагирует на замечание?
Страницы: 1
Наверх