根据单元格值复制整行并粘贴到新的工作表中，停在空白单元格上

我想弄清楚如何复制一整行，并将其粘贴到特定的工作表基于该行中的一个特定的单元格中的值。 我已经拼凑了几个不同的代码来做我所需要的，除非我需要它结束，一旦它到达一个空白单元格，我不知道如何修改，因为我没有使用循环。 以下是我到目前为止的代码。 任何帮助将不胜感激！！ 此外，这段代码似乎需要很长时间才能运行，所以我可以清理它，使其运行更平滑也将有所帮助！

Option Explicit Sub test2() Dim sh33tname As String Dim issuetyp3 As String Dim i As Long Dim startrow As Long Dim typ3 As String Dim ws As Worksheet Dim sheetexist As Boolean Dim sh As Worksheet sh33tname = "Issues List" issuetyp3 = "E" startrow = 22 Set sh = Sheets(sh33tname) For i = startrow To sh.Range(issuetyp3 & Rows.Count).End(xlUp).row typ3 = sh.Range(issuetyp3 & i).Value For Each ws In ThisWorkbook.Sheets If StrComp(ws.Name, typ3, vbTextCompare) = 0 Then sheetexist = True Exit For End If Next If sheetexist Then copyrow i, sh, ws, issuetyp3 Else InsertSheet type3 Set ws = Sheets(Worksheets.Count) copyrow i, sh, ws, issuetyp3 End If Reset sheetexist Next i End Sub Private Sub copyrow(i As Long, ByRef sh As Worksheet, ByRef ws As Worksheet, issuetyp3 As String) Dim wsrow As Long wsrow = ws.Range(issuetyp3 & Rows.Count).End(xlUp).row + 1 sh.Rows(i & ":" & i).Copy ws.Rows(wsrow & ":" & wsrow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End Sub Private Sub Reset(ByRef x As Boolean) x = False End Sub Private Sub InsertSheet(shname As String) Worksheets.Add(after:=.Sheets(.Sheets.Count)).Name = shname End Sub 

Answer 1

这应该加快一点：

当只需要这些值时，跳过剪贴板并分配值会加快速度。 另外，我的经验法则是如果只有一行，那么不需要第二个子或函数。 我把你所有的被调用的子程序直接放到代码中，然后将其作为函数移出。

 Sub test2() Dim i As Long Dim startrow As Long Dim typ3 As String Dim ws As Worksheet 'Dim sheetexist As Boolean Dim sh As Worksheet issuetyp3 = "E" startrow = 22 Set sh = Sheets("Issues List") For i = startrow To sh.Range(issuetyp3 & startrow).End(xldown).Row typ3 = sh.Range(issuetyp3 & i).Value If sheetexist(typ3) Then Set ws = Sheets(typ3) ws.Rows(ws.Range(issuetyp3 & Rows.Count).End(xlUp).Row + 1).Value = sh.Rows(i).Value Else Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count)) ws.Name = typ3 ws.Rows(ws.Range(issuetyp3 & Rows.Count).End(xlUp).Row + 1).Value = sh.Rows(i).Value End If Next i End Sub Function sheetexist(nm As String) As Boolean sheetexist = False For Each ws In ThisWorkbook.Sheets If StrComp(ws.Name, nm, vbTextCompare) = 0 Then sheetexist = True Exit For End If Next End Function