Question

我正在使用此代码（来自Splitting worksheet into multiple workbooks），当我在第3列中使用短数据库进行过滤时，代码会产生奇迹。但是，我有一个数据库，其中列用作过滤器， aka 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

将excel工作表中的数据拆分为基于列值的多个工作簿

1 个答案: