Excel按名称将工作表数据拆分为新的Excel工作簿

问题描述：

Model   Place
model23 35372
model23 35372
model54 31034
model24 31034
model54 31034
model24 31034

我有此Excel数据(数据较大，为38000行，我可以在此处添加所有数据)我想尝试2条路径.

I Have this Excel data (the data is bigger is 38000 lines+ I can add all here) I want try 2 paths..

1)按名称模型拆分工作表(但我想获取并命名模型并放置.

1)Split the sheets by name model (but I want take and name model and place.

示例:

SheetName:model23

SheetName: model23

 Model    Place
    model23 35372
    model23 35372

2)如果我可以将位置值的范围从x转换为y，然后将其拆分为该范围(例如:30000-40000).

2)If I can take a range for place value from x to y number and split then sheet to this range (example: 30000-40000).

使用绿色框，我想取值并添加到具有模型的新表中，或者如果我可以制作新的Excel文件，则可以添加到更好的表中

With green box i want take values and add to a new sheet with model or better if i can make a new Excel file

答

尝试以下操作，您的数据将被拆分为新的Excel工作簿

新工作簿将保存在 CurPath = ActiveWorkbook.Path&"\"

Option Explicit
Private Sub Split_Data_NewBooks()
    Dim Rng As Range
    Dim List As Collection
    Dim ListValue As Variant
    Dim i As Long
    Dim CurPath As String

    CurPath = ActiveWorkbook.Path & "\"

'   Set the Sheet Name
    With ThisWorkbook.Sheets("Sheet1")

        If .AutoFilterMode = False Then
            Range("A1").AutoFilter
        End If

        Set Rng = Range(.AutoFilter.Range.Columns(1).Address)

        Set List = New Collection

        On Error Resume Next
        For i = 2 To Rng.Rows.Count
            List.Add Rng.Cells(i, 1), CStr(Rng.Cells(i, 1))
        Next i
        On Error GoTo 0

        For Each ListValue In List

            Rng.AutoFilter Field:=1, Criteria1:=ListValue

    '       // Copy the AutoFiltered Range to new Workbook
            .AutoFilter.Range.Copy
             Workbooks.Add
             ActiveSheet.Paste
             ActiveWorkbook.SaveAs Filename:=CurPath & Left(ListValue, 30)
             Cells.EntireColumn.AutoFit
             ActiveWorkbook.Close savechanges:=True

        Next ListValue

        .AutoFilter.ShowAllData
        .AutoFilterMode = False
        .Activate
    End With

End Sub

Excel按名称将工作表数据拆分为新的Excel工作簿

相关推荐