时间戳

首页 > 解决方案 > VBA 将特定行移动到唯一的新工作簿

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

问题描述

对于比我更了解 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

链接到示例表

标签： excelvba

解决方案

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

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 的评论 - 范围内确实可能不止一列，所以我已将他的建议添加到我的答案中。

推荐阅读