vba - Excel 按名称将工作表数据拆分到新的 Excel 工作簿中

Question

这个问题在这里已经有了答案:





Create a new sheet for each unique agent and move all data to each sheet

(2 个回答)


5年前关闭。

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

我有这个 Excel 数据(数据更大的是 38000 行+我可以在这里全部添加)
我想尝试2条路径..

1)按名称模型拆分床单(但我想取并命名模型和位置。

例子:

图纸名称:model23

 Model    Place
    model23 35372
    model23 35372

2)如果我可以为 取一个范围地点 从 x 到 y 的值，然后拆分到此范围(例如:30000-40000)。



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

Answer 1

尝试以下操作，您的数据将被拆分到新的 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