Question

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

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

这应该加快一点：

当只需要值时，跳过剪贴板并分配值会加快一些速度。另外，我的经验法则是，如果只有一行，则不需要第二个子或函数。我将所有被调用的subs直接合并到代码中，并移动了我将用作函数的那个。

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

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

1 个答案: