基于单元值的复制和粘贴循环

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