无需选择 vba 即可复制和粘贴

Posted 2023-03-06

技术标签:

【中文标题】无需选择 vba 即可复制和粘贴【英文标题】：Copy and Pasting without select vba 【发布时间】：2021-09-06 10:20:44 【问题描述】：

我正在努力使我的代码更好，所以我要做的第一件事是从我的代码中删除所有选择和选择的使用。

我面临的问题是如果不使用 Selection，我将无法获得稳定的代码。用于进行选择的 PFB 代码

Sub findandCopyVisbleCellsinColumn(ByRef wb As Workbook, ByRef ws As Worksheet, ByRef columnNumber As Long)
    Dim lrow, lcolumn As Long
    With wb
        With ws
            
            ws.Activate                  
            Selection.End(xlToLeft).Select
            ws.Range(Cells(1, columnNumber).Address).Offset(1, 0).Select
            ws.Range(Selection, Selection.End(xlDown)).Select
            Selection.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            
        End With
    End With
End Sub

PFB 代码用于调用上述代码并粘贴值

emptyCell = range_End_Method(wb, ws, 3)
Call findandCopyVisbleCellsinColumn(wb, ws1, 7)
ws.Range("C" & emptyCell).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

到目前为止我做了什么

With ws

            ws.Activate
              
            Selection.End(xlToLeft).Select
            lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            lcolumn = ws.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
            .Range(.Cells(.Cells(2, columnNumber).Address).Offset(1, 0), lrow, lcolumn).Copy
            
End With

这给出了无效属性分配的错误。我怀疑这是由于将单元格分配给单元格，请指出正确的方向。

提前致谢。

【问题讨论】：

A Selection 始终只是 Range - 您可以通过单独使用 Range 来避免选择 - 也适用于复制和粘贴。 PFB是什么意思？ @Darren 不确定，但我怀疑“请在下面查找”。 OP 本可以将其排除在外。 @TomBrunberg 这就是我的想法，但也可能是您伸出舌头并吹气时发出的声音（或者那是 pffffft）。我总是询问缩写词以避免混淆。这能回答你的问题吗？ VBA - copy filtered range without select 【参考方案1】：

复制列中的可见单元格

对我的帖子Function vs Sub(ByRef) 的反馈对我理解ByVal 和ByRef 之间的区别（以及意外错误处理）有点开创性。基本上，令您惊讶的是，您很少需要ByRef。

Option Explicit

Sub YourPBFCode()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets("source")
    Dim dws As Worksheet: Set dws = wb.Worksheets("target")
    
    CopyVisibleCellsInColumn sws.Range("G2"), dws.Range("C2")
 
End Sub

' Just a test (example).
Sub CopyVisibleCellsInColumnTEST()

    Const sName As String = "Sheet1"
    Const sAddr As String = "A2"
    Const dName As String = "Sheet2"
    Const dAddr As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sfCell As Range: Set sfCell = sws.Range(sAddr)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim difCell As Range: Set difCell = dws.Range(dAddr)

    CopyVisibleCellsInColumn sfCell, difCell

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Copies the visible cells of a one-column range to another
'               one-column range. The source range is defined by its first cell
'               and the last cell in its column of its worksheet's used range.
'               The column of the destination range is defined by its first
'               initial cell. The first row of the destination range
'               will be the row of the last non-empty cell in the column
'               increased by one aka the first available row.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CopyVisibleCellsInColumn( _
        ByVal SourceFirstCell As Range, _
        ByVal DestinationInitialFirstCell As Range)
    If SourceFirstCell Is Nothing Then Exit Sub
    If DestinationInitialFirstCell Is Nothing Then Exit Sub
    
    ' Create a reference to the Source Range ('srg').
    Dim sfCell As Range: Set sfCell = SourceFirstCell.Cells(1)
    Dim srg As Range: Set srg = RefVisibleCellsinColumn(sfCell)
    If srg Is Nothing Then Exit Sub ' no data
    
    ' Create a reference to the Destination Range ('drg').
    Dim difCell As Range: Set difCell = DestinationInitialFirstCell.Cells(1)
    Dim dfCell As Range: Set dfCell = RefFirstAvailableCellInColumn(difCell)
    If dfCell Is Nothing Then Exit Sub ' no available cells
    Dim srCount As Long: srCount = srg.Cells.Count
    If srCount > dfCell.Worksheet.Rows.Count - dfCell.Row + 1 Then
        Exit Sub ' does not fit
    End If
    Dim drg As Range: Set drg = dfCell.Resize(srCount)
    
    ' Write values from the Source Range to the Destination Array ('dData').
    Dim dData As Variant: dData = GetColumnMultiRange(srg)
    
    ' Write values from the Destination Array to the Destination Range.
    drg.Value = dData
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the visible cells of the range
'               at the intersection of the one-column range from the first cell
'               of a range ('FirstCellRange') to the bottom-most worksheet cell,
'               and the used range of the worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefVisibleCellsinColumn( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    
    Dim fCell As Range: Set fCell = FirstCellRange.Cells(1)
    Dim wsrCount As Long: wsrCount = fCell.Worksheet.Rows.Count
    Dim crg As Range: Set crg = fCell.Resize(wsrCount - fCell.Row + 1)
    
    On Error Resume Next
    Set RefVisibleCellsinColumn = _
        Intersect(crg.Worksheet.UsedRange, crg).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In the one-column range ('crg') from the first cell ('fCell')
'               of a range ('FirstCellRange') to the bottom-most worksheet cell,
'               creates a reference to the first available cell
'               i.e. the cell below the last non-empty cell ('lCell.Offset(1)').
'               If the one-column range ('crg') is empty,
'               the first cell ('fCell') is also the first available cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstAvailableCellInColumn( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    
    Dim fCell As Range: Set fCell = FirstCellRange.Cells(1)
    Dim wsrCount As Long: wsrCount = fCell.Worksheet.Rows.Count
    Dim crg As Range: Set crg = fCell.Resize(wsrCount - fCell.Row + 1)
    Dim lCell As Range: Set lCell = crg.Find("*", , xlFormulas, , , xlPrevious)
    
    If lCell Is Nothing Then
        Set RefFirstAvailableCellInColumn = fCell
    Else
        If lCell.Row < wsrCount Then
            Set RefFirstAvailableCellInColumn = lCell.Offset(1)
        End If
    End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of the first columns of each single range
'               of a multi-range in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnMultiRange( _
    ByVal ColumnMultiRange As Range) _
As Variant
    On Error GoTo ClearError ' too many areas, "RTE '7': Out of memory"
    If ColumnMultiRange Is Nothing Then Exit Function
    
    Dim aCount As Long: aCount = ColumnMultiRange.Areas.Count
    Dim aData As Variant: ReDim aData(1 To aCount, 1 To 2)
    Dim ocData As Variant: ReDim ocData(1 To 1, 1 To 1)
    
    Dim arg As Range
    Dim a As Long
    Dim arCount As Long
    Dim drCount As Long
    For Each arg In ColumnMultiRange.Areas
        a = a + 1
        With arg.Columns(1)
            arCount = .Rows.Count
            If arCount = 1 Then ' one cell
                ocData(1, 1) = .Value
                aData(a, 1) = ocData
            Else ' multiple cells
                aData(a, 1) = .Value
            End If
        End With
        aData(a, 2) = arCount
        drCount = drCount + arCount
    Next arg
    'Debug.Print aCount, arCount, drCount
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
    
    Dim ar As Long
    Dim dr As Long
    For a = 1 To aCount
        For ar = 1 To aData(a, 2)
            dr = dr + 1
            dData(dr, 1) = aData(a, 1)(ar, 1)
        Next ar
    Next a

    GetColumnMultiRange = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume ProcExit
End Function

【讨论】：

【参考方案2】：

很难解释你在选择范围时出了什么问题。

.Range(.Cells(.Cells(2, columnNumber).Address).Offset(1, 0), lrow, lcolumn)

Range 是工作表中的一个或多个单元格。 Cells 是工作表中的单个单元格 - 使用行号和行列或字母引用。所以Cells(1,1) 会起作用，Cells(1,"A") 也会起作用。您的代码提供了一个完整的单元格地址 - 尝试这样做 Cells("A1")。

这就是我不选择任何东西的方式：

Sub Test()

    'Copy data from sheet1 to sheet2 in a different workbook.
    CopyAndPaste ThisWorkbook.Worksheets("Sheet1"), _
                 Workbooks("Book4").Worksheets("Sheet2")
                 
    'Copy data from sheet1 to sheet2 in workbook that contains this code.
    CopyAndPaste ThisWorkbook.Worksheets("Sheet1"), _
                 ThisWorkbook.Worksheets("Sheet2")

End Sub

Private Sub CopyAndPaste(Source As Worksheet, Target As Worksheet)

    Dim LastCell As Range
    Set LastCell = GetLastCell(Source)

    With Source
        'Copies a range from A1 to LastCell and pastes in Target cell A1.
        .Range(.Cells(1, 1), LastCell).Copy Destination:=Target.Cells(1, 1)
    End With

End Sub

Private Function GetLastCell(ws As Worksheet) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With ws
        lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set GetLastCell = .Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

注意实际的复制/粘贴是一行：.Range(.Cells(1, 1), LastCell).Copy Destination:=Target.Cells(1, 1)

这会将Source 工作表上的范围从单元格A1 (1,1) 复制到GetLastCell 函数返回的任何范围。由于该函数返回一个范围对象，因此可以直接使用 - 无需查找地址并将其单独传递给另一个范围对象。然后将复制的单元格粘贴到 Target 工作表上的单元格 A1。只要您有正确的工作表引用，代码就会知道工作表属于哪个工作簿 - 不需要 With wb:With ws - ws 引用已经包含 wb 引用。

【讨论】：

一个疑问，我正在尝试你建议的方式，但我遇到了一个奇怪的错误，我的代码调用如下

findandCopyVisbleCellsinColumn(ByRef wb As Workbook, ByRef source As Worksheet, ByRef target As Worksheet, ByRef sourceColumnNumber As Long, ByRef targetColumnNumber As Long)

，我也将它们声明为'Dim wb As Workbook , ws, ws1 As Worksheet` Set wb = ThisWorkbook Set ws = ThisWorkbook.Sheets("source") Set ws1 = ThisWorkbook.Sheets("target")' but I am getting a ByRef 参数类型不匹配 ` 到目前为止，我一直只在代码中使用 ByRef，可以如果我将子声明更改为ByVal，它可以工作，但它会失败，因为它的编码为ByRef，考虑到代码（函数调用）是什么可能是失败的原因之前和ByRef一起工作？？？

以上是关于无需选择 vba 即可复制和粘贴的主要内容，如果未能解决你的问题，请参考以下文章

怎样用excel无格式复制粘贴

VBA：如果工作簿中的工作表名称等于从用户窗体中选择的组合框值，则复制该工作表并将其粘贴到另一个工作簿中

VBA复制表1有数据的单元格粘贴到表2，只粘贴数值，不要公式。

使用 VBA 宏选择和复制 Outlook 电子邮件正文

访问自动修改复制粘贴的 VBA 事件代码

VBA研究关于复制粘贴的语句