根据第一列的内容将电子表格分成单独的文件[关闭]

Question

我有一个包含 13 列和 20,000 多行的电子表格。它按 A 列升序排列。 A 列 (DPK) 有大约 700 个不同的值。我需要为大约 700 个值中的每个值保存一个单独的 .xlsx 文件，其中包含标题（2 行）、13 列以及适用于该列 A 值的尽可能多的行，该值也应该是文件名。

我四处寻找，发现了一些人做过类似的练习，但没有一个完全符合我的需要，而且他们看起来都彼此截然不同。我选择了一个看起来更简单的方案（让我搞乱的变量更少），并尝试针对示例文件（上面）修改它，但我无法让它运行。

所以，第一个DPK文件（1000-2100.xlsx）应该有标题（我想我可以整理出这一点），然后是87行数据，第二个DPK（1001-2800.xlsx）应该有标题、22行数据等

我取得的最好成绩是下标超出范围错误。我对 VBA 的了解相当有限（通常足以了解正在发生的事情，但不足以从头开始做任何事情等）感谢任何帮助。

Sub Separate_book_to_sheets1()
Dim sht As Worksheet
Dim DPK_book As Workbook
Dim DPK_info, DPK_value As Range
Dim DPK As String
Set sht = ActiveWorkbook.Sheets(ASCONS)
Set DPK_info = sht.Range("A3:M347")
sht.Range("A3:A347").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=sht.Range("A3:A347"), Unique:=True
For Each DPK_value In sht.Range("A3:A347")
DPK = DPK_value.Text
Set DPK_book = Workbooks.Add
ActiveWorkbook.SaveAs Filename:="E:\Mike\Work\eCLIPSE\X\Projects\D0077 NEL\-Working\AsCons\DPKs\" & DPK & ".xlsx"
Application.DisplayAlerts = False
sht.Activate
sht.AutoFilterMode = False
DPK_info.AutoFilter field:=2, Criteria1:=DPK
DPK_info.Copy
DPK_book.Activate
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next DPK_value
End Sub

迈克

Answer 1

这是一种稍微不同的方法，您可以更改工作表名称、范围和文件路径以适合您：

Sub FilterAndSave()
    Dim ws As Worksheet
    Dim rng As Range
    Dim rngFilter As Range
    Dim uniqueValues As Collection
    Dim cell As Range
    Dim newWs As Worksheet
    Dim newWb As Workbook
    Dim value As Variant
    Dim filePath As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
    Set rng = ws.Range("A3").CurrentRegion ' Change to your range

    ' Get unique values from the column to filter
    Set uniqueValues = New Collection
    
    Set rngFilter = rng.Columns(1).Cells
    Set rngFilter = rngFilter.Offset(1, 0).Resize(rngFilter.Rows.Count - 1, rngFilter.Columns.Count)
    
    On Error Resume Next
    For Each cell In rngFilter ' Change to the column you want to filter
        uniqueValues.Add cell.value, CStr(cell.value)
    Next cell
    On Error GoTo 0

    ' Loop through unique values and create new workbooks
    For Each value In uniqueValues
        ' Apply filter
        rng.AutoFilter Field:=1, Criteria1:=value ' Change to the column you want to filter

        ' Create new workbook and copy filtered data
        Set newWb = Workbooks.Add
        Set newWs = newWb.Sheets(1)
        rng.SpecialCells(xlCellTypeVisible).Copy Destination:=newWs.Range("A1")

        ' Save the new workbook
        filePath = ThisWorkbook.Path & "\" & value & ".xlsx"
        newWb.SaveAs filePath
        newWb.Close False
    Next value

    ' Clear filter
    ws.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

    MsgBox "Filtered workbooks have been saved."
End Sub