根据列值将excel工作表中的数据拆分为多个工作簿答案

【问题标题】：Splitting data from excel worksheet into multiple workbooks based in a column value根据列值将excel工作表中的数据拆分为多个工作簿
【发布时间】：2016-08-03 13:39:21
【问题描述】：

我正在使用此代码（来自Splitting worksheet into multiple workbooks），当我在第 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

提前致谢！

【问题讨论】：

摆脱On Error Resume Next（见Documentation）。由于这一行，您在代码中遇到的任何错误都将被完全忽略。报告您收到的任何错误消息（编辑您的帖子以包含它们）。然后阅读有关错误处理的文档部分的其余部分。几乎从不有充分的理由使用 OERN。
另外，您正在尝试在一列范围内过滤字段 #35。您链接到的上一篇文章在 cmets 中显示了此更正。
我刚刚更新了代码。仍然没有解决任何问题。有什么建议吗？

标签： vba excel

【解决方案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

【讨论】：