Question

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

会发生什么：当列表完全UNFILTERED时，它将占用每个唯一值的第一行并复制该行，导出并保存它。我需要它来传递包含该值的所有行。

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

我现在很难过。

我真的很感谢你的帮助！

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

Answer 2

如果您按照他/她的建议修改SJR代码，则该代码效果很好。谢谢！

至于我......我对它进行了一些修改，经过一些测试，如果你过滤只包含空白，这将很好。这有点乱，但我相信你可以根据需要调整它。

总的来说，我认为SJR的代码很棒，但如果你必须拥有像我这样的东西，这个临时代码也可以运行。

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
Dim HeaderVal As Variant

SavePath = ThisWorkbook.Path

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



 'Store the header in a variant for later use
If hasHeader = True Then
HeaderVal = ThisWorkbook.Worksheets(1).Rows("1:1")
End If


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"

                 'Unhide all cells
       ActiveSheet.Cells.EntireRow.Hidden = False
       ActiveSheet.Cells.EntireColumn.Hidden = False
       'insert new row
       Range("A1").EntireRow.Insert
       'Set the row equal to headerval from the beginning
       Rows(1).Select
       Rows(1).Value = HeaderVal


                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

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

2 个答案: