Question

我有一个大型数据集，每个行都有一个标识符。整个数据集大约有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时，无法使用cut代替copy，原因是什么？

格式是这样的：

enter image description here

Answer 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

您想为每个Areacodes（名为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

通过标识符将数据集拆分为单个工作表

1 个答案: