View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
Poniente Poniente is offline
external usenet poster
 
Posts: 16
Default Copy paste formulas when running multiple instances of excel

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