Прямая передача значений вместо выбора копирования / вставки между книгами

Question

Я могу выбрать копирование / вставку между книгами, используя записанные макросы.Работает.НО, поскольку я читаю, есть более быстрый способ, который не использует буфер обмена.Надеюсь, кто-то может помочь научить меня ловить рыбу.

Позвольте мне объяснить, что происходит.

• Excel с открытой главной книгой, перейдите в ФАЙЛ ОТКРЫТЬ, затем откройте текстовый файл.
• Пройдите через раздел с разделителями текста.
• При открытии новой текстовой рабочей книги выберите («A2: G2000») нажмите COPY.
• Вернитесь к основному файлу Excel, найдите свой рабочий лист, найдите, что ваш Range ("B6: H6") нажал PASTE.

Вот и все.

Я округлил строки в 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

РЕДАКТИРОВАТЬ: обновил ответ для решения вопросов ОП от комментарии.

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