selection.copy导致selection.pastespecial不工作。 优秀的VBA

我会保持这个快。 大部分作品附带的代码我已经在其他项目上使用它的轻微变化。 注释范围3.copy来自我的最后一个项目。

我目前有问题得到selection.copy复制正确的工作簿中选定的范围。 我已经尝试了许多在脚本中注意到的东西。 但我不能得到selection.copy工作.range.copy将工作，并填充剪贴板。 但我还没有想出如何使用.copy粘贴特殊。

我试图输出到variables..没有工作，因为我认为它可能。 我觉得我不得不在工作簿select/激活上丢失一些东西，但我不知道是什么。 在此先感谢您的任何build议或帮助..我会继续堵塞，看看我能想出来。

这是问题的第一部分。 SRCrange1.select然后selection.copy实际上不复制指定的select。 完整的代码如下 。

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

首先，相对的欢迎SO！

其次，一些技巧可以使VBA编程更轻松：

1. 使用选项显式和总是维度和声明你的variablestypes。
2. 命名variables时，使其易于理解和遵循。 所以，如果你要创build一个工作表variables，就像wksCopy一样。 或者，如果您打算命名工作簿，请将其称为wkbCopyTo
3. 您不需要使用.Select和.Activate，而是可以直接使用您的对象。 而且，通过声明适当的variablestypes，这使得在每次需要它们时在代码中处理这些对象变得更加容易。
4. 我不知道是否在Excel或其他应用程序（如Access）中运行此代码，但是如果您在Excel中，则无需创buildExcel对象，因为您可以直接使用Excel应用程序。 如果您使用Access / Word / PPT等来启动代码，请忽略此选项。

所有这些提示使您的代码在尝试debugging和写入时更容易阅读和理解并遵循。

所有这一切，我已经重构了上面的代码，以合并大多数这些原则（我保持所有的variables名称完好，所以你不会迷路在任何重新命名。）如果这个重写不直接解决你的问题=它可能不是，因为代码对我来说是一种令人困惑的写作，我认为你会更容易跟随和理解，并找出它在你debugging时没有做的事情。 另外，如果你弄不清楚的话，我认为这将帮助我们帮助你。

 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

只是添加到其他答案：对于连续的范围，你不需要使用复制这个操作（pastespecial >>值+转置）

 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

不需要select一个范围，然后复制select，当你可以直接复制一个范围：

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