基于单元格的复制和粘贴循环 [英] Copy and Paste Loop based on Cell value

问题描述

下面的宏创建了一个宏，帮助其他的工作。

Created a macro below thanks to help from another that works.

基本上，它需要列A中的单元格的值，如果表单不存在该单元格名称，则创建它。然后，将具有相应单元格值的所有数据行粘贴到该工作表。 IE浏览器。如果单元格包含以下内容：

Basically, it takes the value of the cell in column A and, if a sheet doesn't exist with that cells name, creates it. Then it pastes all rows of data that have the corresponding cell value to that sheet. Ie. if a cell contains the following:

column a  column b
dc00025   data value

如果dc00025不存在，它将使该工作表。并使用dc00025在A中粘贴所有行。

If dc00025 doesn't exist, it'll make the sheet. And paste all rows with dc00025 in A.

这样做完美。但是，我注意到，当您在创建表格后运行此宏，由于某些原因，它会添加数千列，从而大大减慢了excel。

This works perfectly. However, I noticed when you run this macro after a sheet has already been created, for some reason it adds thousands of columns dramatically slowing down excel.

要解决这个问题，有可能修改脚本只能复制列b：o而不是整个行？从A3开始粘贴它们是比较好的，但我不知道如何解决这个问题。

To fix this, would it be possible to modify the script to only copy columns b:o rather tahnt he entire row? Pasting them starting at A3 would be preferable but I'm not sure how to fix that.

提前感谢。

 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

推荐答案

建议修正：

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

这篇关于基于单元格的复制和粘贴循环的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！