在Excel中复制一行，如果它匹配一个特定的标准到一个新的工作表

我是VBA的新手，并且在将一行中的行复制到另一个行中时遇到了一些问题。

我试图在这个论坛上寻找答案，尝试修改代码来适应我的要求，但不成功。 请帮帮我。

1. 我需要在工作表的A列中searchno.s。 search应该从1号开始，然后是2号开始，然后是3号开始，依此类推。
2. 无论何时find“1”，将整个行复制到“Sheet 1”。
3. 完成search“1”后，开始“2”。 当find匹配项时，将整行复制到“工作表2”。
4. 同样没有“3”等。
5. 对其他no.s重复此search，直到A列结束。

我已经尝试了以下代码：注意：我将从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

这是另一种方法。 我不喜欢使用filter，我更喜欢循环每个logging。 也许这是一个慢点，但我认为它更强大。

• 下面应该工作，但我不明白，如果你想将行粘贴到当前工作簿或新的工作簿中的新工作表。
• 下面的代码粘贴到当前的工作簿中，但可以轻松更改。
• 我还假设你会想要将新行粘贴到工作表中，所以你不想覆盖你写的任何以前的数据。

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

试试这个代码。 它将在列A中列出“1号”，“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 

Answer 3

@ 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 eg 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