根據單元格值進行復制和粘貼循環

Question

在下面的宏的幫助下，創建了一個宏。

基本上，它采用A列中單元格的值，如果不存在具有該單元格名稱的工作表，則創建它。 然后，它將具有相應單元格值的所有數據行粘貼到該工作表。 就是 如果單元格包含以下內容：

column a  column b
dc00025   data value

如果dc00025不存在，它將制作工作表。 並將所有帶有dc00025的行粘貼到A中。

這很完美。 但是，我注意到在創建工作表之后運行此宏時，由於某種原因，它會添加成千上萬的列，從而極大地降低了excel的速度。

要解決此問題，是否可以將腳本修改為僅復制列b：而不是整行復制？ 最好從A3開始粘貼它們，但我不確定如何解決。

提前致謝。

 Sub CopyCodes()

    Application.ScreenUpdating = False
    Dim rCell As Range
    Dim lastrow As Long
    lastrow = Sheets("Data").UsedRange.Rows.Count
    For Each rCell In Worksheets("Data").Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
        If Not SheetExists(rCell.Value) Then
            With Worksheets.Add(, Worksheets(Worksheets.Count))
            .Name = rCell.Value
            End With
        End If

        Worksheets("Data").Rows(1).EntireRow.Copy Worksheets(rCell.Value).Rows(1)
        Worksheets(rCell.Value).Range("A" & Rows.Count).End(xlUp)(2).EntireRow.Value = _
        rCell.EntireRow.Value

    Next rCell
    Application.ScreenUpdating = True

End Sub
Function SheetExists(wsName As String)
    On Error Resume Next
    SheetExists = Worksheets(wsName).Name = wsName
End Function

Answer 1

建議的修復方法：

Sub CopyCodes()

    Application.ScreenUpdating = False
    Dim rCell As Range
    Dim lastrow As Long
    Dim shtData as worksheet, shtDest as worksheet
    Dim sheetName as string

    set shtData=worksheets("Data")

    lastrow = shtData.cells(rows.count,1).end(xlup).row        
    For Each rCell In shtData.Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)

        sheetName = rCell.Value
        If Not SheetExists(sheetName) Then
            set shtDest = Worksheets.Add(, Worksheets(Worksheets.Count))
            shtDest.Name = sheetName
            shtData.Rows(1).EntireRow.Copy shtDest.Rows(1)
        Else
            set shtDest = Worksheets(sheetName)              
        End If

        shtDest.Range("A" & Rows.Count).End(xlUp).offset(1,0).EntireRow.Value = _
                                                            rCell.EntireRow.Value

    Next rCell
    Application.ScreenUpdating = True

End Sub