0

各行に割り当てられた識別子を持つ大きなデータセットがあります。データセット全体に約10の異なる識別子がありますが、これは可変である可能性があります。目的は、メインのデータセットを識別子のグループごとに個別のワークシートに分割することです。私はこのコードを以下に書きましたが、これは仕事をしますが、すべてのワークシートを作成するループと各行を通過する別のループで非常に不格好に見えます。

    ...

    '--> Get list of Area Codes
    ws1.Range("N:N").Copy
    Set TempWS = Sheets.Add
    With TempWS
        With .Range("A:A")
            .PasteSpecial
            .AdvancedFilter xlFilterInPlace, Unique:=True
            .SpecialCells(xlCellTypeVisible).Copy
        End With
        .Range("B:B").PasteSpecial
        .ShowAllData
        .Range("A:A").Delete
        .Rows(1).Delete
        tmpLR = .Range("A" & Rows.Count).End(xlUp).Row + 1
    End With

    '--> Create Worksheet for Each Code
    i = 1
    Do Until i = tmpLR
    Set ws = Sheets.Add
    ws.Name = TempWS.Cells(i, 1).Text
    ws1.Range("A1").EntireRow.Copy
    ws.Rows("1:1").PasteSpecial
    i = i + 1
    Loop

    TempWS.Delete

    '--> Break Up Main Data Sheet into Area Code Sheets
    Set rng = ws1.Range("N2:N" & LRws1)
    For Each c In rng
        shname = c.Text
        c.EntireRow.Copy
        Set oWS = Sheets(shname)
        oLR = oWS.Range("A" & Rows.Count).End(xlUp).Row + 1
        oWS.Rows(oLR).PasteSpecial
    Next

    ...

複数回ループする代わりに、このプロセスを完了するためのより効率的な方法はありますか？

また、この行では、の代わりにc.entirerow.copyを使用できないことに気付きました。これの理由は何ですか？cutcopy

フォーマットは次のようになります。

ここに画像の説明を入力してください

4

1 に答える 1

1

私がよく読むことができれば、元のメインテーブルは簡略化された形式で次のようになります。

HEADER1          HEADER2          HEADER3          AREACODES
Area1_Value1     Area1_Value2     Area1_Value3     Area1
Area2_Value1     Area2_Value2     Area2_Value3     Area2
Area3_Value1     Area3_Value2     Area3_Value3     Area3

エリアコード (Area1、2、3 という名前) ごとに新しいシートを作成し、ヘッダーと対応する行を入力します。
以下に記述されているコードは、私が描いたテーブル フォームのフレームワークにすぎません。このコードは、必要に応じてカスタマイズできます。 

Sub Area_Codes()

Dim oRange                  As Range
Dim oRange_Headers          As Range
Dim vArray_Headers          As Variant
Dim oRange_Area             As Range
Dim vArray_Area             As Variant
Dim oRange_Area_Dest        As Range

Dim lRange_Rows             As Long
Dim iRange_Cols             As Integer
Dim vArray                  As Variant

Dim oSheet_Main             As Excel.Worksheet
Dim oSheet                  As Excel.Worksheet
Dim lUse_Row                As Long

Dim lCnt                    As Long
Dim lCnt_B                  As Long
Dim bExists                 As Boolean


Const AreaCodes_Col = 4


Set oSheet_Main = ThisWorkbook.Sheets(1)
Set oRange = oSheet_Main.UsedRange
lRange_Rows = oRange.Rows.Count
iRange_Cols = oRange.Columns.Count
ReDim vArray(1 To lRange_Rows, 1 To iRange_Cols)
vArray = oRange

'load your headers into a separate range 
Set oRange_Headers = oRange.Rows(1)
'Set dimensions of the array equal to dimensions of the range and load range into memory (array) 
ReDim vArray_Headers(1 To 1, 1 To iRange_Cols)
vArray_Headers = oRange
'Clear the range from memory 
Set oRange_Headers = Nothing

'Start as from row 2 (Row 1 = header) 
For lCnt = 2 To lRange_Rows
    'Clear the row containing the area code info from memory - reload on every loop 
    Set oRange_Area = Nothing
    'Exceptional activate
    oSheet_Main.Activate
    'Set row of Area + load into memory 
    Set oRange_Area = oSheet_Main.Range(Cells(lCnt, 1), Cells(lCnt, iRange_Cols))
    ReDim vArray_Area(1 To 1, 1 To iRange_Cols)
    vArray_Area = oRange_Area

    'Check if sheet exists, load result into boolean value 
    bExists = False
    For Each oSheet In ThisWorkbook.Sheets
        If oSheet.Name = vArray(lCnt, AreaCodes_Col) Then
            bExists = True
        End If
    Next oSheet

    'Add sheet if sheet doesn't exist + name 
    Set oSheet = Nothing
    If Not bExists Then
        Set oSheet = Sheets.Add
        oSheet.Name = (vArray(lCnt, AreaCodes_Col))
    Else
        'Define sheet object if sheet already exists 
        Set oSheet = ThisWorkbook.Sheets(vArray(lCnt, AreaCodes_Col))
        oSheet.Activate
    End If

    'Define destination range of headers; You could name this otherwise, to avoid confusion 
    Set oRange_Headers = oSheet.Range(Cells(1, 1), Cells(1, iRange_Cols))
    oRange_Headers = vArray_Headers

    'Check last row used, +1 sets the last row + 1 -> the destination row         
    lUse_Row = oSheet.UsedRange.Rows.Count + 1
    Set oRange_Area_Dest = oSheet.Range(Cells(lUse_Row, 1), Cells(lUse_Row, iRange_Cols))
    'Fill in the destination row 
    oRange_Area_Dest = vArray_Area
Next lCnt

End Sub
于 2012-10-25T13:20:26.970 に答える