使用 Excel 2007 VBA 过滤 Excel 文件

Question

所以我在这里尝试实现的是根据特定值过滤一个巨大的 Excel 文件，然后只显示具有这些值的行。如果可能的话，我还想将这些复制并粘贴到另一个工作簿中，而不覆盖任何现有数据。我所做的是从我们的数据库中运行一个报告并将其导出为一个以时间戳命名的 Excel 文件。有 26 列数据。 B 列是我的“过滤”目标。值为 1、2、3、4、5、6、7、8、9、10、11 或 12（表示一年中的月份）。例如，我想过滤所有 12 月的数据，将其从电子表格复制到另一个主文件工作簿中。如果无法复制部分，我仍然希望能够隐藏任何不是 12 月的数据。然后，我还需要取消隐藏这些数据并过滤掉除 11 月 (11) 之外的所有数据。任何帮助将不胜感激。

Answer 1

这听起来像是无需 VBA 脚本即可轻松完成的事情。尝试使用 Excel 自动过滤器。将其应用于列（不仅仅是一个范围）。然后，您可以根据月份列过滤结果以选择单个月份。要将过滤后的数据移动到新工作簿，请选择范围，将您的选择更改为仅可见单元格 (ALT + ;) 复制数据，然后将其粘贴到其他位置。

您可以在 Excel 中使用 VBA 以编程方式执行此操作。这是我从用户“Dan Wagner”VBA code to Filter data and create a new sheet and transfer data to it找到的脚本

Option Explicit
Sub BringItAllTogether()

Dim DataSheet As Worksheet, TransfersSheet As Worksheet
Dim DataRng As Range, CheckRng As Range, _
    TestTRANS As Range, TestTRSF As Range, _
    CopyRng As Range, PasteRng As Range

'make sure the data sheet exists
If Not DoesSheetExist("DataSheet", ThisWorkbook) Then
    MsgBox ("No sheet named ""DataSheet"" found, exiting!")
    Exit Sub
End If

'assign the data sheet, data range and check range
Set DataSheet = ThisWorkbook.Worksheets("DataSheet")
Set DataRng = DataSheet.Range("$A$1:$H$4630")
Set CheckRng = DataSheet.Range("$B$1:$B$4630")

'make sure that trans or trsf exists in the check range
Set TestTRANS = CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole)
Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole)
If TestTRANS Is Nothing And TestTRSF Is Nothing Then
    MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!")
    Exit Sub
End If

'apply autofilter and create copy range
With DataRng
    .AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:="=*trans*"
End With
Set CopyRng = DataRng.SpecialCells(xlCellTypeVisible)
DataSheet.AutoFilterMode = False

'make sure a sheet named transfers doesn't already exist, if it does then delete it
If DoesSheetExist("Transfers", ThisWorkbook) Then
    MsgBox ("Whoops, ""Transfers"" sheet already exists. Deleting it!")
    Set TransfersSheet = Worksheets("Transfers")
    TransfersSheet.Delete
End If

'create transfers sheet
Set TransfersSheet = Worksheets.Add
TransfersSheet.Name = "Transfers"

'paste the copied range to the transfers sheet
CopyRng.Copy
TransfersSheet.Range("A1").PasteSpecial Paste:=xlPasteAll

End Sub

Public Function DoesSheetExist(SheetName As String, BookName As Workbook) As Boolean
    Dim obj As Object
    On Error Resume Next
    'if there is an error, sheet doesn't exist
    Set obj = BookName.Worksheets(SheetName)
    If Err = 0 Then
        DoesSheetExist = True
    Else
        DoesSheetExist = False
    End If
    On Error GoTo 0
End Function

希望这会有所帮助！