selection.copy导致selection.pastespecial无法工作。excel VBA

Question

我会保持这个速度的。所附代码大部分是我在其他项目中使用过的轻微变化的代码。注释掉的范围3.拷贝来自我的上一个项目。

我目前在让selection.copy在正确的工作簿中复制选定的范围时遇到了问题。我尝试了很多东西，有些在脚本中有记录。但是我无法让selection.copy工作，.range.copy将工作并填充剪贴板。但我还没有弄清楚如何特别使用.copy。

我试着输出变量..。不像我想的那样有效。我觉得我必须在工作簿的选择/激活中遗漏一些东西，但我不知道是什么。预先感谢您的任何建议或帮助。我会继续封堵，看看能不能弄清楚。

这里是这个问题的第一个部分。选择，然后selection.copy实际上不会复制指定的选择。完整的代码在下面。

      Dim MyColumn As String
    Dim Here As String
    Dim AC As Variant

     'SRCrange1.copy  ': This will copy to clipboard

       'objworkbook.Worksheets("plan").Range("b6:h7").Select  no change from SRCrange1.select
       'SRCrange1.Select 'the range does select
        'Selection.copy  '  this will cause a activecell in DSTwb _
        to be copied neither direct reference to SRCrange1.select or .avtivate will change that.


DSTwb.Select
             DSTwb.Range("b2").Select
             Here = ActiveCell.Address
             MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
             Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
             lastrow.Select
             Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

全码

Sub parse()
Dim strPath As String
Dim strPathused As String


'On Error Resume Next


Set objexcel = CreateObject("Excel.Application")
objexcel.Visible = True
objexcel.DisplayAlerts = False
strPath = "C:\prodplan"
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objfso.GetFolder(strPath)


'Loop through objWorkBooks
For Each objfile In objFolder.Files

    If objfso.GetExtensionName(objfile.Path) = "xlsx" Then
        Set objworkbook = objexcel.Workbooks.Open(objfile.Path)
                                ' Set path for move to at end of script
                                strPathused = "C:\prodplan\used\" & objworkbook.Name

'open WB to consolidate too
                        Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

'Range management sourcebook
        Set SRCwb = objworkbook.Worksheets("plan")
        Set SRCrange1 = objworkbook.Worksheets("plan").Range("b6:i7")
        Set SRCrange2 = objworkbook.Worksheets("plan").Range("k6:p7")
        'Set SRCrange3 = objworkbook.Worksheets("").Range("")

'Range management sourcebook
        Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")
        'Set DSTrange1 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
        'Set DSTrange2 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
        'Set DSTrange3 = Workbooks("plancon.xlsx").Worksheets("data").Range("")

'start header dates and shifts copy from objworkbook to consolidated WB
                SRCwb.Select
                'On Error Resume Next
                'SRCwb.Cells.UnMerge

Dim MyColumn As String
Dim Here As String
Dim AC As Variant

 'SRCrange1.copy  ': This will copy to clipboard

   'objworkbook.Worksheets("plan").Range("b6:h7").Select  no change from SRCrange1.select
   'SRCrange1.Select 'the range does select
    'Selection.copy  '  this will cause a activecell in DSTwb _
    to be copied neither direct reference to SRCrange1.select or .avtivate will change that.
         DSTwb.Select
         DSTwb.Range("b2").Select
         Here = ActiveCell.Address
         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
         lastrow.Select
         Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True


   SRCrange2.Select
    Selection.copy
         Workbooks("plancon.xlsx").Worksheets("sheet1").Select
         ActiveSheet.Range("b2").Select
         ActiveSheet.Range("b2").Activate
         Here = ActiveCell.Address
         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
         lastrow.Select
         Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

'    range3.copy
'         Workbooks("data.xlsx").Worksheets("sheet1").Activate
'         ActiveSheet.Range("c2").Select
'         ActiveSheet.Range("c2").Activate
'         Here = ActiveCell.Address
'         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
'         ActiveSheet.Paste Destination:=lastrow


                    'start loop for objworkbook name copy to field in plancon corisponding with date/shift and copy/paste select row data.

    objworkbook.Close False
                        'Move proccesed file to new Dir

    OldFilePath = objfile 'original file location
        NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

End If

Next

objexcel.Quit




End Sub

Answer 1

首先，一个相对的欢迎如此！

其次，为您提供一些可以使VBA编程更轻松的技巧：

1. 使用选项显式和始终维度，并声明变量类型。
2. 在命名变量时，使它们易于理解和跟踪。因此，如果要创建工作表变量，请将其命名为wksCopy。或者，如果要将工作簿命名为wkbCopyTo
3. ，则不需要使用.Select和.Activate，而是可以直接使用对象。此外，通过声明适当的变量类型，这样可以在每次需要时在代码中更容易地处理这些对象。
4. --我不知道您是否在Excel中运行这段代码，或者其他应用程序(如Access) --但是如果您在Excel中，就不需要创建Excel对象，因为您可以直接使用Excel。如果您使用Access / Word / PPT等来触发代码，则忽略它。

所有这些技巧使您的代码更容易阅读和理解，并在尝试调试和编写时遵循。

尽管如此，我已经对上面的代码进行了重构，以包含大部分这些原则(我保持了所有变量名称的完整性，这样您就不会在任何重命名中迷失方向)。如果这种重写不能直接解决您的问题=它可能不会解决问题，因为所编写的代码对我来说有点混乱，我认为您可以更容易地理解和了解它在哪里不像您调试时所期望的那样。而且，如果你想不出来的话，我想它会帮助你的。

Sub parse()

    Dim strPath As String, strPathused As String
    Dim objexcel As Excel.Application

    Set objexcel = CreateObject("Excel.Application")
    With objexcel
        .Visible = True
        .DisplayAlerts = False
    End With

    strPath = "C:\prodplan"

    Dim objfso As FileSystemObject, objFolder As Folder

    Set objfso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objfso.GetFolder(strPath)


    'Loop through objWorkBooks
    For Each objfile In objFolder.Files

        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Dim objWorkbook As Excel.Workbook
            Set objWorkbook = objexcel.Workbooks.Open(objfile.Path)

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name

            'open WB to consolidate too
            objexcel.Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

            'Range management sourcebook
            Dim SRCwb As Excel.Worksheet, SRCrange1 As Excel.Range, SRCrange2 As Excel.Range

            Set SRCwb = objWorkbook.Worksheets("plan") 'sjh -> to me wb implies wb, but you set it to a worksheet (could be a style thing, but worth pointing out
            Set SRCrange1 = objWorkbook.Worksheets("plan").Range("b6:i7")
            Set SRCrange2 = objWorkbook.Worksheets("plan").Range("k6:p7")


            'Range management sourcebook
            Set DSTwb = Excel.Worksheet
            Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB
            Dim MyColumn As String
            Dim Here As String
            Dim AC As Variant

            Here = DSTwb.Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

            'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
            Dim lastrow As Range
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange1.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)


            'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange2.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            objWorkbook.Close False

            'Move proccesed file to new Dir

            OldFilePath = objfile 'original file location
            NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

        End If

    Next

objexcel.Quit

End Sub

如果您在Excel中运行所有这些，则更新。只需使用下面的代码。我把这两种代码都留在了我的回答中，以防你不在Excel上运行。

Option Explicit

Sub parse()

    Application.DisplayAlerts = False

    Dim strPath As String, strPathused As String
    strPath = "C:\prodplan"

    Dim objfso As FileSystemObject, objFolder As Folder

    Set objfso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objfso.GetFolder(strPath)


    'Loop through objWorkBooks
    For Each objfile In objFolder.Files

        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Dim objWorkbook As Workbook
            Set objWorkbook = Workbooks.Open(objfile.Path)

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name

            'open WB to consolidate too
            Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

            'Range management sourcebook
            Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range

            Set SRCwb = objWorkbook.Worksheets("plan")
            Set SRCrange1 = SRCwb.Range("b6:i7")
            Set SRCrange2 = SRCwb.Range("k6:p7")

            'Range management sourcebook
            Dim DSTwb As Worksheet
            Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB
            Dim MyColumn As String
            Dim Here As String
            Dim AC As Variant

            Here = DSTwb.Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

           'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
            Dim lastrow As Range
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange1.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

           'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange2.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            objWorkbook.Close False

            'Move proccesed file to new Dir

            OldFilePath = objfile 'original file location
            NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

        End If

    Next

End Sub

Answer 2

只需添加到其他答案:对于相邻范围，您不需要在此操作中使用复制(面糊>>值+转置)

Sub CopyValuesTranspose()

    Dim rngCopy As Range, rngPaste As Range

    Set rngCopy = Range("A1:B10")
    Set rngPaste = Range("D1")

    rngPaste.Resize(rngCopy.Columns.Count, rngCopy.Rows.Count).Value = _
                                   Application.Transpose(rngCopy.Value)

End Sub

Answer 3

如果可以直接复制范围，则不需要选择范围，然后复制所选内容：

objworkbook.Worksheets("plan").Range("b6:h7").Copy
same_or_different_Range.PasteSpecial Paste:=xlPasteValues, _
    operation:=xlNone, skipblanks:=False, Transpose:=True