如果将特定条件与新工作表匹配，则将其复制到Excel中 [英] Copy a row in excel if it matches a specific criteria into a new worksheet

问题描述

我是VBA的新手，并根据某些标准将一张表中的行复制到另一张。

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

我已经尝试在此搜索一个答案论坛，尝试修改代码以适应我的要求，但不成功。请帮助我。

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. 我需要在工作表的A列中搜索no.s。搜索应以1号，2号，3号等为起点。


2. 每当找到1时，将整行复制到Sheet 1。


3. 完成搜索1后，开始2。当找到匹配项时，将整行复制到Sheet 2。


4. 同样的3等等。


5. 重复此搜索其他no.s直到列A的末尾。

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到预定值不同。

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

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

推荐答案

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

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.

• 以下内容应该可以正常工作，但是我不明白是否要将该行粘贴到当前工作簿中的新工作表中或新的工作簿。
  


• 以下代码粘贴到当前工作簿中，但可以轻松更改。
  


• m也假设您将要保留粘贴新行到工作表中，因此您不希望覆盖以前写入的任何数据。
  



• 您还可以要放置一些额外的错误检查，如确保工作表中的工作表退出，确保列A中的值为数字等。以下没有。

• 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

这篇关于如果将特定条件与新工作表匹配，则将其复制到Excel中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！