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

Posted 2023-02-25

【中文标题】将每个唯一值从一张纸复制并粘贴到另一张纸上

【英文标题】：Copy & paste each unique value from one sheet to another

【发布时间】：2018-11-26 08:12:11

【问题描述】：

我在 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 列中找到一个唯一值（将与其他工作表具有完全相同的名称），请找到此工作表并将整行粘贴到那里。

【问题讨论】：

到目前为止你有什么尝试？

欢迎来到 Stack Overflow。请注意，由于这不是免费的代码编写服务，因此有必要显示您迄今为止尝试过的内容以及遇到的问题或错误（通过显示您的代码），或者至少显示您的研究内容和所做的努力.否则，它只是要求我们为您完成所有工作。阅读How to Ask 可能会帮助您改进您的问题。您的问题过于笼统，无法给出答案，也请查看minimal reproducible example。

当然，抱歉！我已经编辑了主帖。

我仍然很困惑你的目标是什么。首先你说“我正在寻找一个代码，它将具有唯一值的每一行复制并粘贴到一个新的工作表中。”但最后你说“这个宏正在创建新工作表，这不是必需的。”。请更详细地描述您的宏实际上应该做什么。更具体。实际问题尚不清楚。

对不起！我不清楚，我同意。我要做的是：在 K 列中可以存储 8 个不同的值。例如，单元格 K10 可以是“Marek”，单元格 K11 可以具有值“Peh”，K12 将再次具有“Marek”，等等。我已经在同一个工作簿中创建了不同的工作表 - “Marek”、“Peh”等。我想做的是跟随。如果宏在 K 列中找到“Marek”，则整行将被复制并粘贴到单元格“A10”中的工作表“Marek”中。如果宏在我的主表的下一行的 K 列中再次找到“Marek”，则整行将粘贴到工作表“Marek”的单元格“A11”中。谢谢！

【参考方案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

【讨论】：

嗨，米哈尔，谢谢您的帮助！但是，你能提供一些 cmets 吗？它不起作用，我在行 lng= .Range("D" & Rows.Count).End(xlUp) 上收到错误消息“运行时错误“13”/类型不匹配'

@MarekRe 试试lng = .Range("D" & .Rows.Count).End(xlUp).Row，结果他忘了.Row。

@MarekRe - 立即尝试，修正错字。

【参考方案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

感谢大家的帮助和时间！

【讨论】：

我强烈建议阅读并申请How to avoid using Select in Excel VBA。我还建议激活Option Explicit：在 VBA 编辑器中转到 Tools › Options › Require Variable Declaration。两者都能让您的代码更稳定、更快、更安全，并减少错误。