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:

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

--------------------


--
Leith Ross


------------------------------------------------------------------------
Leith Ross's Profile: http://www.excelforum.com/member.php...o&userid=18465
View this thread: http://www.excelforum.com/showthread...hreadid=480102