复制和粘贴具有相同工作表名称的值

Question

我有一个 VBA 程序，它需要根据工作表名称来复制和粘贴值。
工作表名称将在特定列（Bin 列）中提取，并将作为添加工作表的名称基础。有没有一种方法可以复制这些值并根据它们的 Bin 值粘贴它们？

例如，我的 bin 值是 QWE, RTY, UIO，它们在原始工作表上重复，这就是我创建列表的原因。然后创建列表后，Sub CreateSheets() 将创建工作表QWE、工作表RTY 和工作表UIO。我的问题是如何根据工作表名称和设置编号粘贴值。

样本数据表

这是我提取和创建垃圾箱列表（删除重复值）的代码

Sub BIN_Values_List()
 
Dim rSelection As Range
Dim ws As Worksheet

Range("F3:F" & Range("F" & Rows.Count).End(xlUp).Row).Select
    
    Set rSelection = Selection
    Set ws = Worksheets.Add
    ws.Name = "BIN LIST"
    
    rSelection.Copy
    
    With ws.Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteValues
    End With
    
    
    ws.UsedRange.RemoveDuplicates Columns:=Array(1), Header:=xlGuess
    
    On Error Resume Next
    ws.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
    On Error GoTo 0
    
    ws.Columns("A").AutoFit
    
    Application.CutCopyMode = False
        


End Sub

创建列表后，此代码将根据 bin 列表以及结果模板创建和重命名工作表。

Sub CreateSheets()
 
lastcell = ThisWorkbook.Worksheets("BIN LIST").Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lastcell

With ThisWorkbook

newname = ThisWorkbook.Worksheets("BIN LIST").Cells(i, 1).Value

.Sheets.Add after:=.Sheets(.Sheets.Count)

ActiveSheet.Name = newname

Sheets("RESULT TEMPLATE").Range("A1:E205").Copy
ActiveSheet.Paste

End With

Next

ThisWorkbook.Worksheets("SHEET1").Activate
ThisWorkbook.Worksheets("SHEET1").Cells(1, 1).Select

End Sub

Answer 1

这似乎是您要编码的方案：-

“遍历工作表“BIN LIST”中的所有行，并将每个项目复制到名称由“BIN”列指示的工作表中。如果工作表不存在，请将其添加到工作簿中。”

您已经有一个调用每一行的循环，但您需要重新调整它的用途以执行所需的操作，即复制数据并粘贴到另一个工作表。使用下面的函数来获取工作表。如果工作表不存在，它将以正确的名称创建工作表。我把它设为Private，因为它会被你的主程序调用，可能是Public。

Private Function CurrentSheet(ByVal SheetName As String) As Worksheet

    Dim Fun         As Worksheet            ' function return object
    Dim AppStatus   As Boolean              ' current setting of ScreenUpdating
    Dim Ws          As Worksheet            ' ActiveSheet

    With ThisWorkbook
        On Error Resume Next
        Set Fun = Worksheets(SheetName)
        If Err Then
            ' the error that occured results from the sheet not being available
            With Application
                AppStatus = .ScreenUpdating ' remember current setting
                .ScreenUpdating = False     ' disable updating
            End With
            Set Ws = ActiveSheet            ' remember the current ActiveSheet
            
            ' this will create a new sheet and activate it
            Set Fun = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            Fun.Name = SheetName
            
            ' return the status to what it was
            Ws.Activate
            Application.ScreenUpdating = AppStatus
        End If
    End With
    Set CurrentSheet = Fun
End Function

而且，更重要的是，您绝对必须避免激活工作表和选择任何内容。您可以读取和写入任何工作表，无论它是活动的还是可见的。您应该努力保持在用户启动宏时处于活动状态的工作表。

将从您的循环中调用上述函数，并从 BIN LIST 中获取所需的参数（工作表名称）。但是为了测试的目的，你可以使用这个小程序，就像我一样。

Sub Test_CurrentSheet()

    Dim Ws      As Worksheet
    
    Set Ws = CurrentSheet("QWE")
    Debug.Print Ws.Name
End Sub