vba 如果匹配特定条件，则将 Excel 中的一行复制到新工作表中

Copy a row in excel if it matches a specific criteria into a new worksheet

提问by rgm4kor

I'm a novice to VBA and having issues in copying rows in one sheet to another based on certain criteria.

我是 VBA 的新手，并且在根据某些标准将一张工作表中的行复制到另一张工作表时遇到问题。

I have tried searching for an answer in this forum, tried modifying the code to suit my requirement but been unsuccessful. Please help me.

我曾尝试在此论坛中寻找答案，尝试修改代码以满足我的要求，但未成功。请帮我。

1. I need to search for no.s in column A of a worksheet. The search should start with No. 1, then 2, then 3 and so on.
2. Whenever "1" is found, copy the entire row to "Sheet 1".
3. After completing search for "1", start for "2". When a match is found, copy entire row to "Sheet 2".
4. Similarly No. "3" and so on.
5. Repeat this search for other no.s till end of column A.

1. 我需要在工作表的 A 列中搜索编号。搜索应从 1 号开始，然后是 2 号，然后是 3 号，依此类推。
2. 每当找到“1”时，将整行复制到“工作表 1”。
3. 完成搜索“1”后，开始搜索“2”。找到匹配项后，将整行复制到“工作表 2”。
4. 同样编号“3”等。
5. 对其他编号重复此搜索，直到 A 列结束。

I have tried the following code: Note: i will vary from 1 to a pre-determined value.

我已经尝试了以下代码： 注意：我将在 1 到预定值之间变化。

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As Integer

Set wb1 = ActiveWorkbook
Set ws1 = wb1.Worksheets("Burn Down")
strSearch = "1"

With ws1

    '~~> Remove any filters
    .AutoFilterMode = False

    '~~> I am assuming that the names are in Col A
    '~~> if not then change A below to whatever column letter
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    With .Range("A3:A" & lRow)
        .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
        Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    '~~> Remove any filters
    .AutoFilterMode = False
End With

'~~> Destination File
Set wb2 = Application.Workbooks.Open("C:\CSVimport\Sample.xlsx")
Set ws2 = wb2.Worksheets("Sheet" & i)

With ws2
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A3"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lRow = 1
    End If

    copyFrom.Copy .Rows(lRow)
End With

wb2.Save
wb2.Close

采纳答案by Eddie

Here's an alternative way of doing it. I don't like using filters, I prefer to loop through each record. Maybe it's a litte slower but I think it's more robust.

这是一种替代方法。我不喜欢使用过滤器，我更喜欢遍历每条记录。也许它有点慢，但我认为它更强大。

• The below should work but I didn't understand if you wanted to paste the row into a new worksheet in the current workbook or a new workbook.
  
• The below code pastes into the current workbook but that can easily be changed.
  
• I'm also assuming you will want to keep pasting new rows into the worksheet so therefore you don't want to overwrite any previous data you have written.
  

• You would also want to put in some extra error checking like ensure the worksheet\workbook exits, ensure the value in Column A is numeric etc. The below has none.

  Sub copyBurnDownItem()
  
  
  Dim objWorksheet As Worksheet
  Dim rngBurnDown As Range
  Dim rngCell As Range
  Dim strPasteToSheet As String
  
  'Used for the new worksheet we are pasting into
  Dim objNewSheet As Worksheet
  Dim rngNextAvailbleRow As Range
  
  'Define the worksheet with our data
  Set objWorksheet = ThisWorkbook.Worksheets("Burn Down")
  
  
  'Dynamically define the range to the last cell.
  'This doesn't include and error handling e.g. null cells
  'If we are not starting in A1, then change as appropriate
  Set rngBurnDown = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count,     "A").End(xlUp).Row)
  
  'Now loop through all the cells in the range
  For Each rngCell In rngBurnDown.Cells
  
  objWorksheet.Select
  
  If rngCell.Value <> "" Then
      'select the entire row
      rngCell.EntireRow.Select
  
      'copy the selection
      Selection.Copy
  
      'Now identify and select the new sheet to paste into
      Set objNewSheet = ThisWorkbook.Worksheets("Sheet" & rngCell.Value)
      objNewSheet.Select
  
      'Looking at your initial question, I believe you are trying to find the next     available row
      Set rngNextAvailbleRow = objNewSheet.Range("A1:A" &     objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
  
  
      Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
      ActiveSheet.Paste
  End If
  
  Next rngCell
  
  objWorksheet.Select
  objWorksheet.Cells(1, 1).Select
  
  'Can do some basic error handing here
  
  'kill all objects
  If IsObject(objWorksheet) Then Set objWorksheet = Nothing
  If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
  If IsObject(rngCell) Then Set rngCell = Nothing
  If IsObject(objNewSheet) Then Set objNewSheet = Nothing
  If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
  
  End Sub
  

• 下面应该可以工作，但我不明白您是否想将该行粘贴到当前工作簿或新工作簿中的新工作表中。
  
• 以下代码粘贴到当前工作簿中，但可以轻松更改。
  
• 我还假设您希望继续将新行粘贴到工作表中，因此您不想覆盖以前编写的任何数据。
  

• 您还需要进行一些额外的错误检查，例如确保工作表\工作簿退出，确保 A 列中的值是数字等。下面没有。

  Sub copyBurnDownItem()
  
  
  Dim objWorksheet As Worksheet
  Dim rngBurnDown As Range
  Dim rngCell As Range
  Dim strPasteToSheet As String
  
  'Used for the new worksheet we are pasting into
  Dim objNewSheet As Worksheet
  Dim rngNextAvailbleRow As Range
  
  'Define the worksheet with our data
  Set objWorksheet = ThisWorkbook.Worksheets("Burn Down")
  
  
  'Dynamically define the range to the last cell.
  'This doesn't include and error handling e.g. null cells
  'If we are not starting in A1, then change as appropriate
  Set rngBurnDown = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count,     "A").End(xlUp).Row)
  
  'Now loop through all the cells in the range
  For Each rngCell In rngBurnDown.Cells
  
  objWorksheet.Select
  
  If rngCell.Value <> "" Then
      'select the entire row
      rngCell.EntireRow.Select
  
      'copy the selection
      Selection.Copy
  
      'Now identify and select the new sheet to paste into
      Set objNewSheet = ThisWorkbook.Worksheets("Sheet" & rngCell.Value)
      objNewSheet.Select
  
      'Looking at your initial question, I believe you are trying to find the next     available row
      Set rngNextAvailbleRow = objNewSheet.Range("A1:A" &     objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
  
  
      Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
      ActiveSheet.Paste
  End If
  
  Next rngCell
  
  objWorksheet.Select
  objWorksheet.Cells(1, 1).Select
  
  'Can do some basic error handing here
  
  'kill all objects
  If IsObject(objWorksheet) Then Set objWorksheet = Nothing
  If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
  If IsObject(rngCell) Then Set rngCell = Nothing
  If IsObject(objNewSheet) Then Set objNewSheet = Nothing
  If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
  
  End Sub
  

回答by rgm4kor

@Eddie the code finally worked. This is how it looks:

@Eddie 代码终于奏效了。这是它的外观：

Sub Copy()

Dim objWorksheet As Worksheet
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range

'Define the worksheet with our data
Set objWorksheet = ActiveWorkbook.Sheets("Burn Down")

'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("A3:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells

objWorksheet.Select

If rngCell.Value <> "" Then
    'select the entire row
    rngCell.EntireRow.Select

    'copy the selection
    Selection.Copy

    'Now identify and select the new sheet to paste into
    Set objNewSheet = ActiveWorkbook.Sheets("Burn Down " & rngCell.Value)
    objNewSheet.Select

    'Looking at your initial question, I believe you are trying to find the next     available row
    Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
'MsgBox "Success"
    objNewSheet.Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select

    ActiveSheet.Paste

End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

End Sub

回答by raybiss

Try this code. It will go through a list of entries like "No. 1", "No. 2", ... in column A.

试试这个代码。它将通过 A 列中的“No. 1”、“No. 2”等条目列表。

It starts with checking sheets availability and then copy each row to the appropriate sheet. You might need to adjust to your particular scenario but it should work.

它首先检查工作表的可用性，然后将每一行复制到适当的工作表。您可能需要适应您的特定场景，但它应该可以工作。

Sub CopyRowsToSheets()

    On Error Resume Next

    Dim wbk As Workbook
    Set wbk = ThisWorkbook

    Dim sht As Worksheet
    Set sht = wbk.Sheets("Burn Down")

    Dim shtTarget As Worksheet

    Dim rng As Range
    Dim iRow As Integer

    Dim i As Integer
    Dim iMax As Integer

    'get max value
    Set rng = sht.Range("A1")
    While rng.Value <> ""
        i = CInt(Mid(rng.Value, 4))
        If i > iMax Then iMax = i
        Set rng = rng.Offset(1, 0)
    Wend
    'MsgBox iMax

    'check sheets availability
    For i = 1 To iMax
        If wbk.Sheets("Sheet" & i) Is Nothing Then
            MsgBox "Sheet" & i & " is missing"
            Exit Sub
        End If
    Next

    'copy to other sheets
    Set rng = sht.Range("A1")
    While rng.Value <> ""
        i = CInt(Mid(rng.Value, 4))
        rng.EntireRow.Copy

        Set shtTarget = wbk.Sheets("Sheet" & i)
        shtTarget.Activate
        iRow = shtTarget.Range("A" & shtTarget.Rows.Count).End(xlUp).Row + 1
        shtTarget.Range("A" & iRow).Select
        DoEvents
        shtTarget.Paste
        Set rng = rng.Offset(1, 0)
    Wend
End Sub