VBA 将特定行移动到唯一的新工作簿

Question

对于比我更了解 VBA 的人来说，这可能真的很容易。如果是将行复制到新工作表中的情况，我可以看到如何执行此操作，但是在复制满足条件的第一个行后，我还没有弄清楚如何让它移动到下一行。我知道我需要告诉它寻找下一行，但我找不到正确的命令。

我希望让宏循环遍历我指定的数据范围，并将一次满足条件的一行复制到一个新的唯一工作簿中。例如，我有 10 条符合条件的记录，我想要输出 10 个工作簿，每个工作簿有一行数据。

目前的代码是：

Sub DPD()

Dim Ws As Worksheet
Dim Items As Range
Dim Item As Range

Set Ws = Worksheets("Out")
Set Items = Ws.Range("MyRange")

For Each Item In Items

Application.DisplayAlerts = False

'If value in column C > 0, copy row to new workbook and save
If Item.Value > 0 Then

    'Select row in active Sheet to copy
    Item.EntireRow.Copy

    'Paste row into new spreadsheet
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ChDir "C:\DPD"
    ActiveWorkbook.SaveAs Filename:="C:\DPD\pf_" & Format(CStr(Now), "yyy_mm_dd_hh_mm") & ".csv", FileFormat:=xlCSV
    ActiveWindow.Close

    Application.DisplayAlerts = True


End If

Next Item

链接到示例sheet

Answer 1

正如我在评论中提到的，问题在于您的命名。这是为您重构的代码。检查一下，因为我删除了一些东西并移动了其他东西。

Sub DPD()

Dim Items As range
Dim Item As range

'Dim WS As Worksheet
Dim newWS As Worksheet
Dim counter As Long

'Set WS = ThisWorkbook.Sheets("sheet_name") ' try avoiding ActiveWorkbook/Sheet
'Set Items = WS.range("MyRange") ' - this is not necessary if you already have a named range

Application.DisplayAlerts = False ' thats right to switch off notifications
Application.ScreenUpdating = False ' but another good idea is to switch off screen update - this will allow vba to work much faster and you won't see blinking display

For Each Item In Range("MyRange") ' here's where you may use your named range directly

'--------------------------------------------------------------------------
' As per @Zac's comment:    
'For Each Item In Items.Rows ' should change the For loop condition
'If Item.Cells(1, 1).Value > 0 Then ' and also update an If statement
'--------------------------------------------------------------------------


'If value in column C > 0, copy row to new workbook and save
    If Item.Value > 0 Then
        Workbooks.Add
        Set newWS = ActiveSheet ' Here is the place where I can't avoid using "ActiveSheet"
        'Select row in active Sheet to copy
        Item.EntireRow.Copy

 'ChDir "C:\DPD" ' no need to change default directory, as you are providing full file name below ↓

        'Paste row into new spreadsheet
        With newWS
            .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            .Parent.SaveAs FileName:="C:\DPD\pf_" & Format(CStr(Now), "yyy_mm_dd_hh_mm") & counter & ".csv", FileFormat:=xlCSV
            .Parent.Close
        End With
        counter = counter + 1
    End If
Next Item

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

更新

根据 Zac 的评论 - 范围内确实可能不止一列，因此我已将他的建议添加到我的答案中。

Answer 2

按照我的建议，试试下面的UDF

Sub DPD()

    ' Variable Declarations
    Dim rItem As Range
    Dim oNewWB As Workbook
    Dim oNewWS As Worksheet
    Dim iCounter As Long: iCounter = 0

    ' Switch updates off
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    ' Loop through all rows in the range
    For Each rItem In Range("MyRange").Rows

        ' Check if column C has a value greater than 0. NOTE: if the cell has text in it (i.e. header column will have text)
        '                                                     excel counts the number of characters in the cell.. which will
        '                                                     be greater than 0 so that line will be copied in a new workbook
        If rItem.Cells(1, 3).Value > 0 Then

            ' Create new workbook and get the first sheet
            Set oNewWB = Workbooks.Add
            Set oNewWS = oNewWB.Sheets(1)

            ' Copy current row
            rItem.Cells(1, 1).EntireRow.Copy

            ' Paste row in new worksheet
            oNewWS.Cells(1, 1).PasteSpecial Paste:=xlPasteValues

            ' Save new workbook and close it
            iCounter = iCounter + 1
            oNewWB.SaveAs Filename:="C:\DPD\pf_" & Format(CStr(Now), "yyy_mm_dd_hh_mm") & counter & ".csv", FileFormat:=xlCSV
            oNewWB.Close

        End If
    Next

    ' Turn on updates
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Answer 3

您的代码基本上可以工作，唯一的问题是文件创建速度如此之快，以至于它们都是在同一秒内创建的，并且

ActiveWorkbook.SaveAs Filename:="C:\DPD\pf_" & Format(CStr(Now), "yyy_mm_dd_hh_mm") & ".csv", FileFormat:=xlCSV

不允许您区分文件。因此，您的所有文件都将具有相同的时间戳并被覆盖。一个简单的解决方案是添加一个计数器

iCounter

每个新文件都会增加，就像这段编辑过的代码一样：

Sub DPD()

Dim Ws As Worksheet
Dim Items As Range
Dim Item As Range
Dim iCounter As Integer

Set Ws = Worksheets("Out")
Set Items = Ws.Range("MyRange")

For Each Item In Items

Application.DisplayAlerts = False

'If value in column C > 0, copy row to new workbook and save
If Item.Value > 0 Then

    'Select row in active Sheet to copy
    Item.EntireRow.Copy

    'Paste row into new spreadsheet
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ChDir "C:\DPD"

    iCounter = iCounter + 1
    ActiveWorkbook.SaveAs Filename:="C:\DPD\pf_" & Format(CStr(Now), "yyy_mm_dd_hh_mm") & iCounter & ".csv", FileFormat:=xlCSV
    ActiveWindow.Close




End If

Next Item

Application.DisplayAlerts = True

End Sub

请注意我也移动了

Application.DisplayAlerts = True

退出循环。否则，屏幕更新将在第一次复制/粘贴后立即开启。