根據列值將數據從excel工作表拆分為多個工作簿

Question

我使用的是這段代碼（從將工作表拆分為多個工作簿 ），當我在第3列中使用簡短的數據庫進行過濾時，該代碼的工作原理令人驚訝。但是，我有一個數據庫，其中該列用作過濾器，又名field ，在35列或“ AI”中，在這種情況下，代碼無法正常工作。 因此，此代碼僅根據已過濾列的值（良好）創建工作簿，但不對數據本身進行過濾，從而創建（在這種情況下）三個相同的文件。 有什么建議么？ 這是我使用的代碼：

Sub CreateBatchWorkbooks()

On Error Resume Next
Application.DisplayAlerts = False

With ThisWorkbook.Sheets("CalcData")  'Replace the sheet name with the raw data sheet name

Set Newsheet = ThisWorkbook.Sheets("cal")

    If Newsheet Is Nothing Then
            Worksheets.Add.Name = "cal"
        Else
            ThisWorkbook.Sheets("cal").Delete
            Worksheets.Add.Name = "cal"
    End If

        FilterField = WorksheetFunction.Match("BatchNumber ()", ThisWorkbook.Sheets("CalcData").Range("1:1"), 0)

        .Columns(FilterField).Copy

            With ThisWorkbook.Sheets("cal")
                .Range("a1").PasteSpecial (xlPasteAll)
                .Columns("a").RemoveDuplicates Columns:=1, Header:=xlYes
            End With

                    For Each cell In ThisWorkbook.Sheets("cal").Columns("a").Cells
                        i = i + 1
                            If i <> 1 And cell.Value <> "" Then
                                .AutoFilterMode = False
                                .Rows(1).AutoFilter field:=FilterField, Criteria1:=cell.Value
                                Set new_book = Workbooks.Add
                                .UsedRange.Copy
                                new_book.Sheets(1).Range("a1").PasteSpecial (xlPasteAll)
                                new_book.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value & ".xlsx"
                                new_book.Sheets(1).UsedRange.Columns.AutoFit
                                new_book.Save
                                new_book.Close
                            End If
                    Next cell

                        ThisWorkbook.Sheets("cal").Delete
End With

End Sub

提前致謝！

Answer 1

我找到了答案。 我將其張貼在這里，以防使用命名表或數據庫的人有所幫助:)

Sub CreateBatchWorkbooks()

On Error Resume Next
Application.DisplayAlerts = False

With ThisWorkbook.Sheets("CalcData")  'Replace the sheet name with the raw data sheet name

Set Newsheet = ThisWorkbook.Sheets("cal")

    If Newsheet Is Nothing Then
            Worksheets.Add.Name = "cal"
        Else
            ThisWorkbook.Sheets("cal").Delete
            Worksheets.Add.Name = "cal"
    End If

        FilterField = WorksheetFunction.Match("BatchNumber ()", ThisWorkbook.Sheets("CalcData").Range("1:1"), 0)

        .Columns(FilterField).Copy

            With ThisWorkbook.Sheets("cal")
                .Range("a1").PasteSpecial (xlPasteAll)
                .Columns("a").RemoveDuplicates Columns:=1, Header:=xlYes
            End With

                    Dim rngFilteredCalcData
                    For Each cell In ThisWorkbook.Sheets("cal").Columns("a").Cells
                        i = i + 1
                            If i <> 1 And cell.Value <> "" Then
                                Set rngFilteredCalcData = .ListObjects("tblCalcData").Range
                                rngFilteredCalcData.AutoFilterMode = False
                                rngFilteredCalcData.AutoFilter field:=FilterField, Criteria1:=cell.Value

                                Set new_book = Workbooks.Add
                                rngFilteredCalcData.SpecialCells(xlCellTypeVisible).Rows.Copy
                                new_book.Sheets(1).Range("a1").PasteSpecial (xlPasteAll)
                                new_book.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value & ".xlsx"
                                new_book.Sheets(1).UsedRange.Columns.AutoFit
                                new_book.Save
                                new_book.Close
                            End If
                    Next cell

                        ThisWorkbook.Sheets("cal").Delete
End With

End Sub