Именование листов и копирование данных на основе имен ячеек

Question

У меня есть база данных, созданная со следующей информацией: Компания, рабочий стол, имя элемента, дата, число и несколько столбцов с числовыми значениями.

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

Возможно ли это?

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

Редактировать: Было свободное время на моих руках и решил поработать над этим.

Sub Zaloz_Arkusze() 

    With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
    End With 

    Dim wbk3 As Workbook 
    Dim wbk4 As Workbook 
    Dim LW As Long 
    Dim LR As Long 
    Dim i As Integer 
    Dim j As Integer 
    Dim test As Integer 
    Dim Rng As Range, rCell As Range, MyTable As Range, MyTable2 As Range 
    i = 1 
    j = 4 

    'Optimize Macro Speed 
     Application.ScreenUpdating = False 
     Application.EnableEvents = False 
     Application.DisplayAlerts = False 
     Application.Calculation = xlCalculationManual 

    Set wbk3 = ActiveWorkbook 
    Set wbk4 = Workbooks.Open("C:\Users\rzakrzewski\Desktop\Przeroby.xlsm") 

    wbk3.Activate 
    Set Rng = Range("A1", Range("R" & Rows.Count).End(xlUp)) 

    LR = Sheets(2).Cells(Rows.Count, "S").End(xlUp).Row 
     Sheets(2).Range("Q1:R" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets(4).Range("A1"), Unique:=True 
    LW = Sheets(4).Range("B1", Sheets(4).Range("B1").End(xlDown)).Rows.Count 

    Set MyTable = wbk3.Sheets(4).Range("B1", Range("B1").End(xlDown)) 
    Set MyTable = wbk3.Sheets(4).Range("A1", Range("A1").End(xlDown)) 

    test = MyTable.Rows.Count 

    wbk3.Sheets(2).Activate 

    For Each rCell In MyTable 
    On Error Resume Next 
     wbk4.Activate 
     wbk4.Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = i 
     wbk3.Activate 
     With Rng 
      .AutoFilter , Field:=18, Criteria1:=rCell.Value 
      .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ 
       wbk4.Sheets(j).Range("A" & Rows.Count).End(xlUp).Offset(1) 
      .AutoFilter 
     End With 
    On Error GoTo 0 
    i = i + 1 
    j = j + 1 

Next rCell 

Application.EnableEvents = True 

    End Sub 

Вышеуказанные сортирует данные по данным компании/имя объекта, копии уникальных записей и создает ряд рабочих листов в отдельной книге по количеству уникальных записей. Я решил пропустить номер именования в соответствии с компанией/объектом. Ограничение длины имени делает это трудно сделать.

Следующая часть, которую я пытаюсь выяснить, заключается в том, чтобы копировать данные для каждой уникальной комбинации и вставлять ее в рабочие листы. Т.е. У меня уникальная комбинация данных в ячейках B1: C6. Мне нужны данные в ячейках D1: T6 копируется во вторую книгу на рабочий лист (1). Не намерены выбирать нужные мне данные. Есть идеи ?

Edit2: Как показано выше, я попытался работать с опцией Autofilter. Проблема в том, что мне нужно выполнить 2 шага для уникальных данных. У компаний есть много объектов под ними, и иногда у одного и того же объекта есть другая компания. Но я понятия не имею, как заставить его работать. Пробовал двойной цикл «Для каждого», но он не работает.

Answer 1

После создания нового рабочего листа можно перемещаться с помощью:

Sheets("NewWorksheetName").Range("A1")="Data"