Question

所以我写了代码，仅从用户标记的活动单元格开始，将剪贴板中复制的范围粘贴到可见的单元格中

我已经优化了我的代码，可以将其速度从7200个/分钟提高到42000个/分钟，但是我认为仍有很大的优化空间。但是由于这是对我来说是VB编程的第三天，我向社区询问了有用的技巧和技巧，以提高我的代码速度

我处理的方式是将剪贴板粘贴到新工作表中然后搜索下一个要插入的可见单元格，我使用可变的最大长度来“限制”搜索，但在我的应用程序中可能看不见数千个单元格。

我曾考虑过使用StringBuilder使其运行更快，但不知道如何实现

重要的是行和列都可以不可见

On Error GoTo ErrorHandler 'Enable Error Handling


Application.ScreenUpdating = False
Dim tblRow1 As Integer, lRow As Integer
Dim tblName As String
Dim lastRow, lastCol As Long
Dim outX, outY As Long
Dim maxLength As Long
clipboardTable As String     
outputTable As String  



outputTable = ActiveSheet.Name 'Safe the Name of the target sheet

outY = ActiveCell.Row           'Safe the Target position in sheet with xY coordinates
outX = ActiveCell.Column

 maxLength = Sheets(outputTable).UsedRange.Rows.Count

outYtmp = outY                  'Is needed to reset the corsur from the bottom to top

Set wbook = ActiveWorkbook
Set clipSheet = wbook.Sheets.Add


clipboardTable = clipSheet.Name

Sheets(clipboardTable).Activate
Sheets(clipboardTable).PasteSpecial


'Start Sheet
Sheets(clipboardTable).Select
lastRow = Sheets(clipboardTable).UsedRange.Rows.Count
lastCol = Sheets(clipboardTable).UsedRange.Columns.Count

'MsgBox ActiveSheet.UsedRange.Rows.Count
'MsgBox ActiveSheet.UsedRange.Columns.Count
'MsgBox " " & Sheets(inTable).Rows(1).EntireRow.Hidden



Sheets(outputTable).Select

For x = 1 To lastCol
Sheets(outputTable).Select
For j = 1 To maxLength
    If Sheets(outputTable).Columns(outX).Hidden = False Then
        For y = 1 To lastRow
            For i = 1 To maxLength
                If Sheets(outputTable).Rows(outY).Hidden = False Then

                    Sheets(outputTable).Cells([outY], [outX]) = Sheets(clipboardTable).Cells([y], [x])
                    outY = outY + 1
                    Exit For

                End If
            outY = outY + 1
            Next
        Next

        outX = outX + 1
        Exit For
    End If
 outX = outX + 1
Next
outY = outYtmp

Next
    Application.DisplayAlerts = False
    Sheets(clipboardTable).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
Exit Sub

    ErrorHandler:  ' Error-handling routine.
    If (Worksheets(clipboardTable).Name <> "") Then
        Application.DisplayAlerts = False
        Sheets(clipboardTable).Delete
    Application.DisplayAlerts = True
End If


End Sub

VBA仅粘贴到可见单元格中的优化

0 个答案: