Question

我在D列中最多可以有8个唯一值。我正在寻找将所有具有唯一值的行复制并粘贴到新工作表中的代码。

所以我最多可能有8张新纸。

您能帮我建立实现此目的的代码吗？

这是我到目前为止所拥有的：

Option Explicit
Sub AddInstructorSheets()
    Dim LastRow As Long, r As Long, iName As String
    Dim wb As Workbook, ws As Worksheet, ts As Worksheet, nws As Worksheet
    Dim i As Integer
    Dim m As Integer

    'set objects
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    Set ts = Sheets("Master")

    'set last row of instructor names
    LastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row

    'add instructor sheets
    On Error GoTo err
    Application.ScreenUpdating = False
    For r = 17 To LastRow 'assumes there is a header
        iName = ws.Cells(r, 4).Value

        With wb 'add new sheet
            ts.Copy After:=.Sheets(.Sheets.Count) 'add template
            Set nws = .Sheets(.Sheets.Count)
            nws.Name = iName
            Worksheets(iName).Rows("17:22").Delete
            Worksheets("Master").Activate
            Range(Cells(r, 2), Cells(r, 16)).Select
            Selection.Copy
            m = Worksheets(iName).Range("A15").End(xlDown).Row
            Worksheets(iName).Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
        End With
    Next r

err:
    ws.Activate
    Application.ScreenUpdating = True  
End Sub

问题是此宏正在创建新的工作表，这不是必需的。我只想关注。

如果您在D列中找到一个唯一值（与其他工作表的名称相同），请找到该工作表并将整行粘贴在其中。

Answer 1

Sub CopyFromColumnD()


    Dim key As Variant
    Dim obj As Object
    Dim i As Integer, lng As Long, j As Long
    Dim sht As Worksheet, mainsht As Worksheet


    Set obj = CreateObject("System.Collections.ArrayList")
    Set mainsht = ActiveSheet

    With mainsht
        lng = .Range("D" & .Rows.Count).End(xlUp).Row
        With .Range("D1", .Range("D" & lng))
            For Each key In .Value
                If Not obj.Contains(key) Then obj.Add key
            Next
        End With
    End With

    For i = 0 To obj.Count - 1
        Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
        sht.Name = obj(i)

        For j = 1 To lng
            If mainsht.Cells(j, 4).Value = obj(i) Then
                    mainsht.Rows(j).EntireRow.Copy Destination:=Range("A1")
                Exit For
            End If
        Next
    Next

 End Sub

Answer 2

好的，我做了解决方法。我在单独的表格中创建了一个唯一值列表。

Sub copypaste() 
    Dim i As Integer 
    Dim j As Integer

    LastRow = Worksheets("Master").Range("D17").End(xlDown).Row

    For i = 17 To LastRow
        For j = 2 To 10
            Workstream = Worksheets("Database").Cells(j, 5).Value

            Worksheets("Master").Activate
            If Cells(i, 4) = Worksheets("Database").Cells(j, 5).Value Then
                Range(Cells(i, 2), Cells(i, 16)).Select
                Selection.Copy
                Worksheets(Workstream).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            Else

            End If    
        Next j 
    Next i
End Sub

感谢大家的帮助和您的时间！

将每个唯一值从一张纸复制并粘贴到另一张纸

2 个答案: