vba - 过滤所有值并导出与每个值相关的所有行

Question

我在让这个宏正常工作时遇到了一些麻烦。基本上我需要它做的是获取一列，过滤该列中的每个唯一字符串，将其导出到新工作簿，并将新工作簿保存为与 xlsm 相同的目录中的过滤值的名称。它几乎完美地工作，除了一件事......

会发生什么:当列表完全未过滤时，它将获取每个唯一值的第一行并复制该行，导出并保存它。我需要它来获取传递列中包含该值的所有行。

如果我过滤该列以仅包含空白，那么它会起作用，但它将省略标题，并且行将隐藏在新创建的文件中。

我现在有点困惑。

非常感谢您的帮助!

Sub TEST()

    Dim hasHeader As Boolean
    Dim colLetter As String
    Dim wb As Workbook
    Dim d As Range
    Dim currentRow As Long
    Dim lastValue As String

    SavePath = ThisWorkbook.Path

    ' CHANGE IF NEEDED'
    hasHeader = True
    ' CHANGE IF NEEDED'
    ' CHANGE IF NEEDED'
    colLetter = "D"
    ' CHANGE IF NEEDED'

    ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ThisWorkbook.Worksheets(1).Sort
        .SetRange Cells

        If hasHeader Then
            .Header = xlYes
        Else
            .Header = xlNo
        End If

        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With

    For Each d In ThisWorkbook.Sheets(1).Range(colLetter & ":" & colLetter)

        If d.value = "" Then Exit For

        If d.Row = 1 And hasHeader = False Then

        Else
            If lastValue <> d.value Then

                If Not (wb Is Nothing) Then
                    wb.SaveAs SavePath & "\" & lastValue & ".xlsx"
                    wb.Close
                End If

                lastValue = d.value
                currentRow = 1
                Set wb = Application.Workbooks.Add
            End If

            ThisWorkbook.Sheets(1).Rows(d.Row & ":" & d.Row).Copy
            wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select
            wb.Sheets(1).Paste
        End If
    Next

    If Not (wb Is Nothing) Then
        wb.SaveAs SavePath & "\" & lastValue & ".xlsx"
        wb.Close
    End If

    MsgBox ("Saved to: " & ThisWorkbook.Path)

End Sub

Answer 1

这是我的代码，因此您必须修改工作表名称、路径等

Sub x()

'For each unique entry in data sheet column D copies corresponding filtered data to report sheet
'copies sheet to new workbook and saves it under name of unique item

Dim r As Long, lrow As Long
Dim rng As Range

Application.DisplayAlerts = False

With Sheets("data")
    lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    Sheets.Add().Name = "temp"
    .Range("D1:D" & lrow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True
     For Each rng In Sheets("temp").Range("A2", Sheets("temp").Range("A2").End(xlDown))
        Sheets("report").Range("B2") = rng
        .AutoFilterMode = False
        .Range("A1").CurrentRegion.AutoFilter field:=4, Criteria1:=rng
        .AutoFilter.Range.Offset(1, 0).Copy Sheets("report").Range("A5")
        Sheets("report").Copy
        ActiveWorkbook.Close SaveChanges:=True, Filename:="C:\" & rng & ".xls"
        Sheets("report").Range("A5:H" & Sheets("report").Cells(Rows.Count, "H").End(xlUp).Row).Clear
    Next rng
    .AutoFilterMode = False
    Sheets("temp").Delete
End With

Application.DisplayAlerts = True

End Sub