直接价值转移，而不是在工作簿之间选择复制/粘贴

Question

我可以使用录制的宏在工作簿之间选择复制/粘贴。它正在工作。但是，在阅读时，我正在学习有一种更快的方法，它不涉及复制/粘贴剪贴板。希望有人能帮助教我钓鱼。

让我解释一下发生了什么。

• 打开主工作簿的 Excel，转到 FILE OPEN 然后打开文本文件。
• 遍历文本分隔部分。
• 在打开新文本工作簿时选择（“A2:G2000”）点击复制。
• 回到主 excel 文件，找到您的工作表，找到您的 Range("B6:H6") 点击粘贴。

就是这样。

我将行四舍五入为 2000，因为这是一个安全的赌注，数据不会通过这一行。但是，我知道有更好的方法。目前，我收到 438 错误对象不支持此属性或方法。也许你可以帮助阐明这一点。

我将附上我的 vba 代码的副本，其中包含贯穿整个过程的 rem 语句。先感谢您。我只是在学习 stackoverflow 的设置，希望我能提前付款。谢谢你，布默

    `Sub import_data()
    '
    ' import_data Macro
    Dim wb1 As Workbook

    Application.ScreenUpdating = False

    'Using FILE-OPEN text file and run thru text delimited setup

  Workbooks.OpenText (Module33.FileDir + "\cf_data.txt"), Origin:=437, _
  StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
  ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
  , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
  Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), 
  TrailingMinusNumbers:=True

        'Applying the newly open excel workbook (text file)to a variable wb1
  Set wb1 = ThisWorkbook

         'Switching to the first sheet within this wb1 workbook
  With wb1.Sheets(1)

         'Selecting Columns A thru G and all rows in each columns that have 
          'values. text or numbers, no formulas.
  lr = .Range("A:G").Find(what:="*", after:=.Range("A1"), 
  searchorder:=xlByRows, _
  searchdirection:=xlPrevious).Row
  .Range(.Cells(2, "A"), .Cells(lr, "G")).Value          '<====Run-time 438 '- Object doesn't support this property or method

  End With

  wb1.Close SaveChanges:=False

        'Switches back to main workbook to sheet 2 then range B6 and paste 
        'all data

  Workbooks("Auto_Data.xlsm").Sheet2.Range("B6").Resize(UBound(arr, 
        1), UBound(arr, 2)) = arr


    'The code below does what I'm wanting however, it is very sluggish. This 
    'code, when in use, will sit just below text delimited section.

'    Range("A2:G2000").Select
'    Selection.Copy
'    Windows("Auto_Data.xlsm").Activate
'    Sheet2.Select
'    Range("B6:H6").Select
'    ActiveSheet.Paste
'    Selection.AutoFilter
'    Application.CutCopyMode = False
'    ActiveWindow.ActivateNext
'    ActiveWindow.Close
'    Range("B4").Select


Application.ScreenUpdating = True

End Sub

Answer 1

所以这里有一个简单的例子供你适应你的需要。您需要注意的是明确您对哪个工作簿、工作表和范围的引用。在这个例子中，唯一被复制的是数据。使用复制/粘贴更适合复制数据和嵌入格式（这不适用于您的情况）。

Option Explicit

Sub ImportData()
    Dim destWB As Workbook
    Set destWB = ThisWorkbook

    Dim textWB As Workbook
    Dim textWS As Worksheet
    Workbooks.OpenText "C:\Temp\testdata.txt", Space:=True
    Set textWB = ActiveWorkbook
    If textWB Is Nothing Then
        MsgBox "Unable to open the text data"
        Exit Sub
    Else
        Set textWS = textWB.Sheets(1)
    End If

    '--- determine the data range and copy to a memory-based array
    Dim lastRow As Long
    Dim lastCol As Long
    Dim textArea As Range
    Dim textData As Variant
    With textWS
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set textArea = .Range("A1").Resize(lastRow, lastCol)
        textData = textArea
    End With

    Dim destWS As Worksheet
    Dim destArea As Range
    Set destWS = destWB.Sheets("Sheet1")
    Set destArea = destWS.Range("A1").Resize(lastRow, lastCol)
    destArea = textData

    textWB.Close SaveChanges:=False
End Sub

编辑： 更新了答案以解决 OP 的问题 厘米。

Sub ImportData2()
    Dim destWB As Workbook
    Set destWB = ThisWorkbook

    Dim textWB As Workbook
    Dim textWS As Worksheet
    Workbooks.OpenText "C:\Temp\testdata.txt", Space:=True
    Set textWB = ActiveWorkbook
    If textWB Is Nothing Then
        MsgBox "Unable to open the text data"
        Exit Sub
    Else
        Set textWS = textWB.Sheets(1)
    End If

    Dim destWS As Worksheet
    Set destWS = destWB.Sheets("Sheet1")

    '--- first range to copy A2:A<lastRow> to destWS A2
    CopyData textWS, 1, 1, destWS, "A2"

    '--- second range to copy E2:E<lastRow> to destWS E2
    CopyData textWS, 5, 1, destWS, "E2"

    '--- third range to copy G2:J<lastRow> to destWS G2
    CopyData textWS, 7, 4, destWS, "G2"

    textWB.Close SaveChanges:=False
End Sub

Private Sub CopyData(ByRef srcWS As Worksheet, _
                     ByVal startColumn As Long, _
                     ByVal numberOfColumns As Long, _
                     ByRef destWS As Worksheet, _
                     ByVal destCell As String)
    Dim lastRow As Long
    Dim textArea As Range
    Dim textData As Variant
    With srcWS
        lastRow = .Cells(.Rows.Count, startColumn).End(xlUp).Row
        Set textArea = .Cells(2, startColumn).Resize(lastRow, numberOfColumns)
        textData = textArea
    End With

    Dim destArea As Range
    Set destArea = destWS.Range(destCell).Resize(textArea.Rows.Count, _
                                                 textArea.Columns.Count)
    destArea = textData
End Sub