基於單元值的複製和粘貼循環

Question

創建一個宏，感謝來自其他人的幫助。

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

column a column b 
dc00025 data value 

如果dc00025不存在，它將生成工作表。並且將所有具有dc00025的行都粘貼在A中。

這很好地工作。不過，我注意到當你創建一個表單後運行這個宏，由於某些原因，它增加了數以千計的列，極大地減慢了excel的速度。

要解決這個問題，是否可以修改腳本以僅複製列b：o而不是整行？從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