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

以上根据公司/对象名称对数据进行排序，复制唯一条目，并根据唯一条目的数量在单独的工作簿中创建数字工作表。我决定根据公司/对象跳过命名部分。名称长度限制使得这很难做到。

下一部分我想弄清楚的是，是为每个独特的组合复制数据并粘贴它的工作表。 IE浏览器。我在Cell B1：C6中有独特的数据组合。我需要单元格D1：T6中的数据复制到第二个工作簿到工作表（1）。不知道选择我需要的数据。有什么想法吗？

Edit2：如上所示，我尝试使用Autofilter Option。问题是，我需要两步检查唯一数据。公司下面有很多对象，有时同一个对象有不同的公司。但我不知道如何让它发挥作用。尝试了一个双“For Each”循环，但它不起作用。

Answer 1

创建新工作表后，您可以使用以下方式导航：

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

根据单元名称命名工作表和复制数据

1 个答案: