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
  

Answer 2

@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

Answer 3

试试这个代码。它将遍历 A 列中的条目列表，例如“No. 1”、“No. 2”、...。

它首先检查工作表的可用性，然后将每一行复制到相应的工作表。您可能需要根据您的特定情况进行调整，但它应该可以工作。

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