Question

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

我尝试在此论坛中搜索答案，尝试修改代码以符合我的要求但未成功。请帮帮我。

我需要在工作表的A列中搜索no.s。搜索应从1号开始，然后是2号，然后是3号，依此类推。
每当找到“1”时，将整行复制到“Sheet 1”。
完成搜索“1”后，从“2”开始。找到匹配项后，将整行复制到“工作表2”。
同样号码“3”等。
重复此搜索以查找其他编号，直到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

这是另一种方法。我不喜欢使用过滤器，我更喜欢循环遍历每条记录。也许它比较慢，但我觉得它更强大。

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

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

试试这段代码。它将通过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 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

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

3 个答案: