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

示例表鏈接

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

您的代碼基本上可以正常工作，唯一的問題是文件的創建速度太快，以至於它們都是在同一秒內創建的，並且

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

跳出循環。 否則，屏幕更新將在第一次復制/粘貼后立即打開。

Answer 3

按照我的建議，試試下面的 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