COPY-PASTE Macro

Hello macXpert,

Here is the macro code. You will need to copy and paste this code into a VB Module. First run the Macro called "AddToCellMenu". This adds a command to the Excel's Cell Popup Menu. Just right click the cell in the destination Workbook and click "Insert Rows/ Paste Here". This calls the "MainMacro", inserts the rows needed, and copies the 6 reference columns into the column of the active cell in the destination workbook. One empty line separates each of the source columns from the next one.

When the macro runs it checks the open workbooks and lists them in an input box. Enter the name of the workbook to be used as the source. I did it this way to keep it simple. This way you can have multple workbooks open, and not be limited to only 2 - the source and destination.

Macro Code:

Public Sub MainMacro()

  Dim Col As Long
  Dim DstRng As Range
  Dim DstWkb As Workbook
  Dim DstWks As Worksheet
  
  Dim Msg As String
  Dim R As Long
  Dim RowStart As Long
  
  Dim SrcRng As Range
  Dim SrcWkb As Workbook
  Dim SrcWks As Worksheet
  Dim WB
  
  
    On Error GoTo Fault
    
    Msg = "Enter the name of the Source Workbook" & vbCrLf _
        & "from the ones listed below." & vbCrLf _
        & "=====================================" & vbCrLf
        
      For Each WB In Excel.Workbooks
        If WB.Name <> ThisWorkbook.Name And WB.Path <> "" Then
          Msg = Msg & WB.Name & vbCrLf
          R = R + 1
        End If
      Next WB
      
    If R = 0 Then
      MsgBox "You Have No Saved Workbooks Open.", vbInformation + vbOKOnly
      Exit Sub
    End If
    
    WB = InputBox(Msg, "Insert and Copy Data")
      If WB = "" Then Exit Sub
    
    'Setup the Workbooks and Worksheets
      Set SrcWkb = Excel.Workbooks(WB)
        SrcWkb.Activate
      Set SrcWks = SrcWkb.ActiveSheet
    
      Set DstWkb = ThisWorkbook
        DstWkb.Activate
      Set DstWks = DstWkb.ActiveSheet

    'Get the Starting Row and Column from the ActiveCell
      RowStart = ActiveCell.Row
      Col = ActiveCell.Column
      
  'Source Range Addresses
    Set SrcRng = SrcWks.Range("B94:B103"): GoSub InsertAndCopy
     Set SrcRng = SrcWks.Range("O94:O103"): GoSub InsertAndCopy
      Set SrcRng = SrcWks.Range("W94:W103"): GoSub InsertAndCopy
       Set SrcRng = SrcWks.Range("AA94:AA103"): GoSub InsertAndCopy
        Set SrcRng = SrcWks.Range("W118:W127"): GoSub InsertAndCopy
         Set SrcRng = SrcWks.Range("AA118:AA127"): GoSub InsertAndCopy
     
   Exit Su


'_________________________________________

    
InsertAndCopy:

    Set DstRng = ActiveCell.Resize(SrcRng.Rows.Count + 1, Col)
    DstRng.Insert (xlDown)
    
      For R = 1 To SrcRng.Rows.Count
        DstWks.Cells(RowStart + R - 1, Col).Value = SrcRng.Item(R, 1).Value
      Next R
      
      RowStart = RowStart + R
      DstWks.Cells(RowStart, Col).Select
      
    Return
    
Fault:
  
  Msg = "There is a problem with the Workbook " & WB & vbCrLf _
      & "Error Number " & Err.Number & vbCrLf _
      & "Description: " & Err.Description
      
  MsgBox Msg, vbCritical + vbOKOnly, "InsertRowsPasteHere Macro"
  
End Sub

Public Sub AddToCellMenu()

 'Add Macro command to the Cell Popup Menu
 
  Dim cbCell As CommandBar
  Dim ctButton As CommandBarButton
  Dim ctDropDown As CommandBarControl
  Dim WB

    Set cbCell = Excel.CommandBars("cell")
    
    Set ctButton = cbCell.Controls.Add
      With ctButton
        .Caption = "Insert Rows/Paste Here"
        .OnAction = "MainMacro"
        .BeginGroup = True
      End With
    
End Sub