拆分剪贴板列并粘贴

Question

我是 vba 新手。请帮忙。

这是我目前的代码

Sub Copy_and_Paste()
'
' Copy_and_Paste Macro
' Copy and Paste for test
'
'
    Windows("testv03.xlsm").Activate   
'  ActiveSheet.Paste

Dim lastRow As String

lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastRow).Select
Selection.PasteSpecial

Range("G16").Select
Selection.ClearComments
End Sub

• 请不要以上代码只能从剪贴板复制粘贴到最后一行

执行的任务 1.复制6列到剪贴板（选择和crtl+c） 2. 然后我想将 5 列和所有行粘贴到最后一行 活动表。 3.然后我想在已经的第6列旁边再粘贴一次 粘贴的数据。即使全部复制，此粘贴任务也必须执行两次 记录排队

例如 复制到剪贴板

NO_PPC  PC_92020    601000  GC.ADM.100  NO_PCO  100.41 
NO_PPC  PC_92040    601000  RA.ADM.100  NO_PCO  100.13 
NO_PPC  PC_94010    601000  FS.ADM.100  NO_PCO  100.19

then paste
NO_PPC  PC_92020    601000  GC.ADM.100  NO_PCO
NO_PPC  PC_92040    601000  RA.ADM.100  NO_PCO  
NO_PPC  PC_94010    601000  FS.ADM.100  NO_PCO

then paste 
100.41
100.13
100.19

文件产品应如下所示粘贴到最后一行。

NO_PPC  PC_92020    601000  GC.ADM.100  NO_PCO  100.41
NO_PPC  PC_92040    601000  RA.ADM.100  NO_PCO  100.13
NO_PPC  PC_94010    601000  FS.ADM.100  NO_PCO  100.19

请帮忙。 问候 阿文什

Answer 1

我肯定会消除您使用 (Ctrl + C) 进行复制的需要，而是通过 VBA 来完成，如下所示，这将从 A:F 复制列并粘贴到您的目的地，然后它将复制 G 列并粘贴到目标 G 列（两个单独的复制/粘贴）：

Sub Copy_and_Paste()
Dim isOpen As Boolean
Dim FilePath As String
Dim lastRow As Long
Dim wsDestination As Worksheet
Dim wbDestination As Workbook
Dim wsCopyFrom As Worksheet

Set wsCopyFrom = ThisWorkbook.Worksheets("Sheet1")
'above set the worksheet you are copying from
lastRow = wsCopyFrom.Cells(wsCopyFrom.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
wsCopyFrom.Range("A1:F" & lastRow).Copy
'copy Columns A to F

FilePath = "testv03.xlsm"
'replace the name of the file with its full path, such as "C:/Users/Me/Documents/testv03.xlsm"
isOpen = IsWorkBookOpen(FilePath)

If Not isOpen Then 'check if workbook is open, if not then open it
    Set wbDestination = Workbooks.Open(FilePath)
End If

Set wsDestination = wbDestination.Sheets("Sheet1")
'above set the sheet you are copying into, amend as required

wsDestination.Range("A1").PasteSpecial
'Paste Columns A to F

wsCopyFrom.Range("G1:G" & lastRow).Copy
'copy Column G
wsDestination.Range("G1").PasteSpecial
'Paste Column G
End Sub

Function IsWorkBookOpen(Name As String) As Boolean
'function to check whether workbook is open
    Dim xWb As Workbook
    On Error Resume Next
    Set xWb = Application.Workbooks.Item(Name)
    IsWorkBookOpen = (Not xWb Is Nothing)
End Function