excel - 如果 Excel 中的行与特定条件匹配，则将其复制到新工作表中

Question

我是 VBA 新手，在根据特定条件将一张纸中的行复制到另一张纸时遇到问题。

我尝试在这个论坛中寻找答案，尝试修改代码以满足我的要求，但没有成功。请帮助我。

1. 我需要在工作表的 A 列中搜索编号。搜索应该从 1 号开始，然后是 2 号，然后是 3 号，依此类推。
2. 只要找到“1”，就将整行复制到“Sheet 1”。
3. 完成搜索“1”后，开始搜索“2”。找到匹配项后，将整行复制到“表 2”。
4. 类似“3”号，依此类推。
5. 重复搜索其他编号，直到 A 列末尾。

我尝试过以下代码:注意:i 将从 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

Answer 1

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

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

• 您还需要进行一些额外的错误检查，例如确保工作表\工作簿退出、确保 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