您好我有以下VBA代码,我尝试将其用于将符合特定条件的行复制并粘贴到新工作表中。
代码运行到复制工作表中的第一个匹配但没有粘贴在第二个工作表上并显示错误
运行时错误' 14004':应用程序定义或对象定义的错误
有人可以帮忙吗?
Sub mileStone()
Dim r As Long, pasteRowIndex As Long
Dim lastRow As Long
'lastRow = sht.Range("A1").CurrentRegion.Rows.Count
lastRow = 24 ' need to include function to retrieve the last used row number
pasteRowIndex = 1
For r = 11 To lastRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("E").Column).Value = "defect resolution" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
答案 0 :(得分:2)
这可能足以摆脱所有那些通常会导致问题并且很少需要的选择(只需要添加工作表引用)。但是,AutoFilter或Find将是更快的方法。
Sub mileStone()
Dim r As Long, pasteRowIndex As Long, v() As Long, i As Long
Dim lastRow As Long
'lastRow = sht.Range("A1").CurrentRegion.Rows.Count
lastRow = 13 '24 ' need to include function to retrieve the last used row number
pasteRowIndex = 1
With Sheets("Sheet1")
For r = 11 To lastRow
If .Cells(r, "E").Value Like "defect resolution*" Then
If UBound(Split(.Cells(r, "E"), ",")) > 0 Then
i = i + 1
ReDim v(1 To i)
v(i) = pasteRowIndex
End If
Sheets("Sheet1").Rows(r).Copy Sheets("Sheet2").Rows(pasteRowIndex)
pasteRowIndex = pasteRowIndex + 1
End If
Next r
End With
With Sheets("Sheet2")
If IsArray(v) Then
.Columns(6).Insert shift:=xlToRight
For i = LBound(v) To UBound(v)
.Cells(v(i), "F") = Split(.Cells(v(i), "E"), ",")(1)
.Cells(v(i), "E") = Split(.Cells(v(i), "E"), ",")(0)
Next i
End If
End With
End Sub
答案 1 :(得分:0)
Sub Copy_Filtered_Sections()
Dim Section As Long, NextRow As Long
For Section = 1 To 32
NextRow = Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row + 1 'Next empty row
Sheets("Function Test Procedure").Select
Range("FTPSec" & Section).Columns("A:H").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("Results").Range("A" & NextRow)
' Range("FTPSec" & Section).Columns("G:H").SpecialCells(xlCellTypeVisible).Copy _
' Destination:=Sheets("Results").Range("N" & NextRow)
Next Section
End Sub
验收测试程序脚本
Sub Copy_ATP_Tables()
Dim SectionATP As Long, NextRow As Long
For SectionATP = 1 To 32
NextRow = Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row + 1 'Next empty row
Sheets("Acceptance Test Procedure").Select
Range("ATPSec" & SectionATP).Columns("A:H").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("Results").Range("A" & NextRow)
' Range("FTPSec" & Section).Columns("G:H").SpecialCells(xlCellTypeVisible).Copy _
' Destination:=Sheets("Results").Range("N" & NextRow)
Next SectionATP
End Sub