For whomever may be interested, the code below seems to work, although
I agree its not a beauty..
Sub PasteFormulas(CopyOriginal As Range, PasteOriginal As Range)
Dim CopyR As Range
Dim PasteR As Range
Dim PasteTemp As Range
Dim Counter As Long
Dim CopyRCells As Long
Dim PasteRCells As Long
Dim CopyRRows As Long
Dim CopyRCols As Long
Dim PasteRRows As Long
Dim PasteRCols As Long
Dim SSh As Worksheet
Dim TSh As Worksheet
Set CopyR = CopyOriginal
Set PasteR = PasteOriginal
CopyRCells = CopyOriginal.Cells.Count
PasteRCells = PasteOriginal.Cells.Count
CopyRRows = CopyOriginal.Rows.Count
CopyRCols = CopyOriginal.Columns.Count
PasteRRows = PasteOriginal.Rows.Count
PasteRCols = PasteOriginal.Columns.Count
' check if or cols or rows are 1
If CopyRRows > 1 And CopyRCols > 1 Then
MsgBox "For PasteFormulas vba, Copy range should either be 1
column or 1 row"
Exit Sub
End If
Dim WbOrg As String
Dim WbCP As String
Select Case CopyRRows
Case 1
' horizontal source
If PasteRCols <> CopyRCols Then
MsgBox "Pasted cols <> to Copied cols"
Exit Sub
End If
If CopyR.Cells(1).Column <= PasteR.Cells(1).Column Then
' copy left of paste
If CopyR.Cells(1).Row <= PasteR.Cells(PasteRCells).Row Then
' copy above paste
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Counter = 1
Do While Counter <= CopyRCols
Set PasteTemp = Range(CopyR.Cells(CopyRCells - Counter
+ 1).Address, _
PasteR.Cells(PasteRCells - Counter + 1).Address)
PasteTemp.Formula = CopyR.Cells(CopyRCells - Counter +
1).Formula
Counter = Counter + 1
Loop
PasteOriginal.Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
Set CopyR = CopyOriginal
Set PasteR = PasteOriginal
CopyRCells = CopyOriginal.Cells.Count
PasteRCells = PasteOriginal.Cells.Count
CopyRRows = CopyOriginal.Rows.Count
CopyRCols = CopyOriginal.Columns.Count
PasteRRows = PasteOriginal.Rows.Count
PasteRCols = PasteOriginal.Columns.Count
If CopyR.Cells(1).Row > PasteR.Cells(1).Row Then
' copy below paste
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Counter = 1
Do While Counter <= CopyRCols
Set PasteTemp = Range(CopyR.Cells(CopyRCells - Counter
+ 1).Address, _
PasteR.Cells(PasteRCols - Counter + 1).Address)
PasteTemp.Formula = CopyR.Cells(CopyRCells - Counter +
1).Formula
Counter = Counter + 1
Loop
PasteOriginal.Resize(Application.WorksheetFunction.Min
(PasteRRows, CopyR.Cells(1).Row - PasteR.Cells(1).Row),
PasteRCols).Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
End If
Set CopyR = CopyOriginal
Set PasteR = PasteOriginal
CopyRCells = CopyOriginal.Cells.Count
PasteRCells = PasteOriginal.Cells.Count
CopyRRows = CopyOriginal.Rows.Count
CopyRCols = CopyOriginal.Columns.Count
PasteRRows = PasteOriginal.Rows.Count
PasteRCols = PasteOriginal.Columns.Count
If CopyR.Cells(1).Column > PasteR.Cells(1).Column Then
' copy right of paste
If CopyR.Cells(1).Row <= PasteR.Cells(PasteRCells).Row Then
' copy above paste
Counter = 1
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Do While Counter <= CopyRCols
Set PasteTemp = Range(CopyR.Cells(Counter).Address, _
PasteR.Cells(PasteRCells - PasteRCols +
Counter).Address)
PasteTemp.Formula = CopyR.Cells(Counter).Formula
Counter = Counter + 1
Loop
' PasteOriginal.Resize(Application.WorksheetFunction.Min
(PasteRRows, CopyR.Cells(1).Row - PasteR.Cells(1).Row),
PasteRCols).Formula = PasteR.Formula
PasteOriginal.Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
Set CopyR = CopyOriginal
Set PasteR = PasteOriginal
CopyRCells = CopyOriginal.Cells.Count
PasteRCells = PasteOriginal.Cells.Count
CopyRRows = CopyOriginal.Rows.Count
CopyRCols = CopyOriginal.Columns.Count
PasteRRows = PasteOriginal.Rows.Count
PasteRCols = PasteOriginal.Columns.Count
If CopyR.Cells(1).Row > PasteR.Cells(1).Row Then
' copy below paste
Counter = 1
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Do While Counter <= CopyRCols
Set PasteTemp = Range(CopyR.Cells(Counter).Address, _
PasteR.Cells(Counter).Address)
PasteTemp.Formula = CopyR.Cells(Counter).Formula
Counter = Counter + 1
Loop
Dim TestInt As Long
PasteOriginal.Resize(Application.WorksheetFunction.Min
(PasteRRows, CopyR.Cells(1).Row - PasteR.Cells(1).Row),
PasteRCols).Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
End If
Case Else
' vertical source
If PasteRRows <> CopyRRows Then
MsgBox "Pasted rows <> to Copied rows"
Exit Sub
End If
If CopyR.Cells(1).Row <= PasteR.Cells(1).Row Then
' copy above paste
If CopyR.Cells(1).Column <= PasteR.Cells(PasteRCells).Column
Then
' copy is left of or at paste
Counter = 1
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Do While Counter <= CopyRCells
Set PasteTemp = Range(CopyR.Cells(CopyRCells - Counter
+ 1).Address, _
PasteR.Cells(PasteRCells - (Counter - 1) *
PasteRCols).Address)
PasteTemp.Formula = CopyR.Cells(CopyRCells - Counter +
1).Formula
Counter = Counter + 1
Loop
PasteOriginal.Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
Set CopyR = CopyOriginal
Set PasteR = PasteOriginal
CopyRCells = CopyOriginal.Cells.Count
PasteRCells = PasteOriginal.Cells.Count
CopyRRows = CopyOriginal.Rows.Count
CopyRCols = CopyOriginal.Columns.Count
PasteRRows = PasteOriginal.Rows.Count
PasteRCols = PasteOriginal.Columns.Count
If CopyR.Cells(1).Column > PasteR.Cells(1).Column Then
' copy is right of paste
' only changes set PasteTemp
Counter = 1
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Do While Counter <= CopyRCells
Set PasteTemp = Range(CopyR.Cells(CopyRCells - Counter
+ 1).Address, _
PasteR.Cells(PasteRCells - (Counter - 1) * PasteRCols
- PasteRCols + 1).Address)
PasteTemp.Formula = CopyR.Cells(CopyRCells - Counter +
1).Formula
Counter = Counter + 1
Loop
PasteOriginal.Resize(PasteRRows,
Application.WorksheetFunction.Min(PasteRCols, CopyR.Cells(1).Column -
PasteR.Cells(1).Column)).Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
Else
' copy below paste
' copy is left of or at paste
If CopyR.Cells(1).Column <= PasteR.Cells(PasteRCells).Column
Then
Counter = CopyRCells
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Do While Counter >= 1
Set PasteTemp = Range(CopyR.Cells(CopyRCells - Counter
+ 1).Address, _
PasteR.Cells(PasteRCells - (Counter - 1) *
PasteRCols).Address)
PasteTemp.Formula = CopyR.Cells(CopyRCells - Counter +
1).Formula
Counter = Counter - 1
Loop
PasteOriginal.Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
' copy is right of paste
' only changes set PasteTemp
Set CopyR = CopyOriginal
Set PasteR = PasteOriginal
CopyRCells = CopyOriginal.Cells.Count
PasteRCells = PasteOriginal.Cells.Count
CopyRRows = CopyOriginal.Rows.Count
CopyRCols = CopyOriginal.Columns.Count
PasteRRows = PasteOriginal.Rows.Count
PasteRCols = PasteOriginal.Columns.Count
If CopyR.Cells(1).Column > PasteR.Cells(1).Column Then
Counter = CopyRCells
WbOrg = ActiveWorkbook.Name
Workbooks.Add
WbCP = ActiveWorkbook.Name
Set CopyR = Range("'[" & WbCP & "]Sheet1'!" &
CopyOriginal.Address)
Set PasteR = Range("'[" & WbCP & "]Sheet1'!" &
PasteOriginal.Address)
CopyR.Formula = CopyOriginal.Formula
Do While Counter >= 1
Set PasteTemp = Range(CopyR.Cells(CopyRCells - Counter
+ 1).Address, _
PasteR.Cells(PasteRCells - (Counter - 1) * PasteRCols
- PasteRCols + 1).Address)
PasteTemp.Formula = CopyR.Cells(CopyRCells - Counter +
1).Formula
Counter = Counter - 1
Loop
PasteOriginal.Resize(PasteRRows,
Application.WorksheetFunction.Min(PasteRCols, CopyR.Cells(1).Column -
PasteR.Cells(1).Column)).Formula = PasteR.Formula
Windows(WbCP).Close savechanges:=False
End If
End If
End Select
End Sub