0

動作する別の人の助けのおかげで、以下のマクロを作成しました。

基本的に、列 A のセルの値を取得し、そのセル名のシートが存在しない場合は作成します。次に、対応するセル値を持つデータのすべての行をそのシートに貼り付けます。すなわち。セルに以下が含まれている場合:

column a  column b
dc00025   data value

dc00025 が存在しない場合は、シートを作成します。そして、A に dc00025 を含むすべての行を貼り付けます。

これは完全に機能します。ただし、シートが既に作成された後にこのマクロを実行すると、何らかの理由で数千の列が追加され、Excel が劇的に遅くなることに気付きました。

これを修正するには、行全体ではなく列のみをコピーするようにスクリプトを変更できますか? 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
4

1 に答える 1

0

推奨される修正:

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
于 2012-12-19T01:04:12.453 に答える