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

时间:2019-03-06 20:17:21

标签: excel vba copy-paste

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

让我解释发生了什么。

  • 打开了主要工作簿的Excel,转到FILE OPEN,然后打开文本文件。
  • 在文本分隔部分中走动。
  • 在打开新文本工作簿的情况下,选择COPY(“ A2:G2000”)。
  • 返回主excel文件,找到您的工作表,找到您的Range(“ B6:H6”)并按PASTE。

就是这样。

我在2000年对行进行了四舍五入,因为这是一个安全的押注,数据不会通过该行。但是,我知道有更好的方法。当前,我收到438错误对象不支持此属性或方法。也许您可以帮助阐明这一点。

我将在过程中附加带有rem语句的vba代码副本。先感谢您。我只是在学习stackoverflow设置,希望我能付钱。谢谢,Boomer

    `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

1 个答案:

答案 0 :(得分: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