drmartinjr3i
New Member
- Joined
- Jan 25, 2010
- Messages
- 1
I have a macro that I have built to copy ranges and charts. The ranges one works great. The chart one works great as well. It duplicates the chart including the title, logos, text boxes and allows for the ranges and axis to be uniqly updated as well by simply offsetting the ranges and axis rows.
It works great that is for about 100 charts after that it really starts to bog down.
I have tried on excel 2003, 2007, 2010 and even the new excel 2010 64 bit
My pc is a quad core 4GHZ 12 GB DD3+ Ram with liquid cooling
My ram barely even moves (the file is only growing about 1MB per 100) my processor are only running at about 25% -
I have done the usual - turn off screenupdating, calculations and events
is there a stack empty or excel cache or some sort of limit feature I can access or something to stop it from slowing down to a grinding halt?
Below is the Code:
Option Explicit
Option Private Module
Sub CopyRange()
Call CopyData(False, True)
End Sub
Sub CopyChart()
Call CopyData(True, False)
End Sub
Sub CopyChartAndRange()
Call CopyData(True, True)
End Sub
Sub CopyData(ByVal CopyChart As Boolean, ByVal CopyRange As Boolean)
'****************************************
Dim wb As Workbook
Dim response As Integer
Dim chrt As Chart
Dim chrtObjs() As ChartObject
Dim selObj As Variant
Dim chrtObj As ChartObject
Dim chrtWS As Worksheet
Dim chrtMessage As String
Dim rng As Range
Dim rngWS As Worksheet
Dim ws As Worksheet
Dim chrtTitles() As Range
Dim foundTitle As Boolean
Dim titleRow As Long
Dim titleCell As Range
Dim hCopies, vCopies As Integer
Dim hOffset, vOffset As Long
Dim chrtHOffsets(), chrtVOffsets() As Double
Dim h, v As Integer
Dim cell1, cell2 As Range
Dim rng2 As Range
Dim c As Long
Dim c1, c2, r1, r2 As Long
Dim wdth, hght As Double
Dim newChrt As Chart
Dim newTitle As String
Dim ser As Series
Dim oldFormula As String
Dim newFormula As String '(R1C1 format)
Dim rng3 As Range
Dim firstChar, lastChar As Integer
Dim foundEnd As Boolean
Dim old1, old2, old3 As String
Dim new1, new2, new3 As String
Dim x, y As Integer
'****************************************
Set wb = Nothing
On Error Resume Next
Set wb = ActiveWorkbook
On Error GoTo 0
If wb Is Nothing Then
ShowError ("You must have an active workbook to use this tool.")
Exit Sub
End If
Set ws = Nothing
ReDim chrtObjs(0)
ReDim chrtTitles(0)
ReDim chrtHOffsets(0)
ReDim chrtVOffsets(0)
If CopyChart = True Then
'See if there is an ActiveChart
Set chrt = Nothing
On Error Resume Next
Set chrt = ActiveChart
On Error GoTo 0
If Not (chrt Is Nothing) Then
ReDim chrtObjs(1)
Set chrtObjs(1) = chrt.Parent
Else
'If no ActiveChart, see if any charts are included in the current Selection
For Each selObj In Selection
Set chrtObj = Nothing
On Error Resume Next
Set chrtObj = selObj
On Error GoTo 0
If chrtObj Is Nothing Then
GoTo NextSelectedObject
Else
ReDim Preserve chrtObjs(UBound(chrtObjs) + 1)
Set chrtObjs(UBound(chrtObjs)) = selObj
End If
NextSelectedObject:
Next
End If
If UBound(chrtObjs) = 0 Then
ShowError ("Please select a chart to copy first.")
Exit Sub
End If
If UBound(chrtObjs) = 1 Then
chrtMessage = "the chart"
Else
chrtMessage = "one of the charts"
End If
Set chrtWS = ActiveSheet
End If
If CopyRange = True Then
Set rng = Nothing
Application.DisplayAlerts = False
On Error Resume Next
Set rng = Application.InputBox(Prompt:="Select the Range to Copy:", _
title:="Microsoft Excel", _
Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rng Is Nothing Then Exit Sub
Set rngWS = rng.Worksheet
End If
If CopyChart = True And CopyRange = True Then
'Check to make sure range and chart are on the same worksheet
If chrtWS.Name <> rngWS.Name Then
ShowError ("Range must be on the same worksheet as the selected chart(s).")
Exit Sub
End If
End If
If CopyChart = True Then
Set ws = chrtWS
Else
Set ws = rngWS
End If
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtTitles(x)
Set chrtTitles(x) = Nothing
If chrt.HasTitle = True Then
foundTitle = False
If CopyRange = True Then
For y = rng.Column To (rng.Column + rng.Columns.Count - 1)
Set cell1 = ws.Cells(rng.Row, y)
Set cell2 = ws.Cells(rng.Row + rng.Rows.Count - 1, y)
Set rng2 = ws.Range(cell1, cell2)
If Not (IsError(Application.Match(chrt.ChartTitle.Text, rng2, 0))) Then
titleRow = Application.Match(chrt.ChartTitle.Text, rng2, 0)
Set titleCell = ws.Cells(titleRow, y)
response = MsgBox("It appears as if " & chrtMessage & " has" & vbCr & _
"a title linked to cell " & titleCell.Address & vbCr & _
"(" & titleCell.Value & ")." & vbCr & _
vbCr & _
"Is this correct?", _
vbYesNoCancel + vbQuestion, _
"Microsoft Excel")
If response = vbCancel Then Exit Sub
If response = vbYes Then
Set chrtTitles(x) = titleCell
foundTitle = True
End If
End If
Next
End If
If foundTitle = False Then
response = MsgBox("Is the title of the chart '" & chrt.ChartTitle.Text & "'" & vbCr & _
"linked to a Cell?", _
vbYesNoCancel, _
"Microsoft Excel")
If response = vbCancel Then Exit Sub
If response = vbYes Then
Set rng2 = Nothing
Application.DisplayAlerts = False
On Error Resume Next
Set rng2 = Application.InputBox(Prompt:="Select the Cell with the Chart's Title:", _
title:="Microsoft Excel", _
Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rng2 Is Nothing Then Exit Sub
If rng2.Rows.Count > 1 Or rng2.Columns.Count > 1 Then
ShowError ("Range for Chart Title must be a single cell!")
Exit Sub
End If
Set chrtTitles(x) = rng2
End If
End If
End If
Next
hCopies = 0
Application.DisplayAlerts = False
On Error Resume Next
hCopies = Application.InputBox(Prompt:="Number of Copies Across:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If hCopies = 0 Then Exit Sub
If (hCopies < 1) Or (Int(hCopies) <> hCopies) Then
ShowError ("Copies Across must be a whole number greater than 0.")
Exit Sub
End If
vCopies = 0
Application.DisplayAlerts = False
On Error Resume Next
vCopies = Application.InputBox(Prompt:="Number of Copies Down:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If vCopies = 0 Then Exit Sub
If (vCopies < 1) Or (Int(vCopies) <> vCopies) Then
ShowError ("Copies Down must be a whole number greater than 0.")
Exit Sub
End If
If hCopies = 1 And vCopies = 1 Then
ShowError ("1 Copy Across x 1 Copy Down = Nothing to Copy!")
Exit Sub
End If
hOffset = 0
If hCopies > 1 Then
Application.DisplayAlerts = False
On Error Resume Next
hOffset = Application.InputBox(Prompt:="Number of Columns to Offset Right:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If hOffset = 0 Then Exit Sub
If (hOffset < 1) Or (Int(hOffset) <> hOffset) Then
ShowError ("Columns to Offset must be a whole number greater than 0.")
Exit Sub
End If
If CopyRange = True Then
If hOffset < rng.Columns.Count Then
ShowError ("This would copy the range partly onto itself!")
Exit Sub
End If
End If
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtHOffsets(x)
If CopyRange = True Then
chrtHOffsets(x) = chrt.Parent.Left - rng.Left
If ws.Cells(1, rng.Column + hOffset).Left + chrtHOffsets(x) < _
chrt.Parent.Left + chrt.Parent.Width Then GoTo ChartHOffsetError
Else
'Find which column the chart starts in
c1 = 1
Do While ws.Cells(1, c1 + 1).Left < chrt.Parent.Left
c1 = c1 + 1
Loop
'Calculate the first column with the offset
c2 = c1 + hOffset
'Calculate the actual offset
chrtHOffsets(x) = ws.Cells(1, c2).Left - ws.Cells(1, c1).Left
'Make sure the column offset is wide enough
If chrtHOffsets(x) < chrt.Parent.Width Then
ChartHOffsetError:
If UBound(chrtObjs) = 1 Then
ShowError ("This would copy the chart partly onto itself!")
Else
ShowError ("This would copy one of the charts partly onto itself!")
End If
Exit Sub
End If
End If
Next
End If
Else
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtHOffsets(x)
If CopyRange = True Then
chrtHOffsets(x) = chrt.Parent.Left - rng.Left
Else
chrtHOffsets(x) = 0
End If
Next
End If
End If
If vCopies > 1 Then
Application.DisplayAlerts = False
On Error Resume Next
vOffset = Application.InputBox(Prompt:="Number of Rows to Offset Down:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If vOffset = 0 Then Exit Sub
If (vOffset < 1) Or (Int(vOffset) <> vOffset) Then
ShowError ("Rows to Offset must be a whole number greater than 0.")
Exit Sub
End If
If CopyRange = True Then
If vOffset < rng.Rows.Count Then
ShowError ("This would copy the range partly onto itself!")
Exit Sub
End If
End If
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtVOffsets(x)
If CopyRange = True Then
chrtVOffsets(x) = chrt.Parent.Top - rng.Top
If ws.Cells(rng.Row + vOffset, 1).Top + chrtVOffsets(x) < _
chrt.Parent.Top + chrt.Parent.Height Then GoTo ChartVOffsetError
Else
'Find which row the chart starts in
r1 = 1
Do While ws.Cells(r1 + 1, 1).Top < chrt.Parent.Top
r1 = r1 + 1
Loop
'Calculate the first row with the offset
r2 = r1 + vOffset
'Calculate the actual offset
chrtVOffsets(x) = ws.Cells(r2, 1).Top - ws.Cells(r1, 1).Top
'Make sure the row offset is high enough
If chrtVOffsets(x) < chrt.Parent.Height Then
ChartVOffsetError:
If UBound(chrtObjs) = 1 Then
ShowError ("This would copy the chart partly onto itself!")
Else
ShowError ("This would copy one of the charts partly onto itself!")
End If
Exit Sub
End If
End If
Next
End If
Else
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtVOffsets(x)
If CopyRange = True Then
chrtVOffsets(x) = chrt.Parent.Top - rng.Top
Else
chrtVOffsets(x) = 0
End If
Next
End If
End If
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++
Application.Calculation = xlCalculationManual
'++++++++++++++++++++++++++++++++++++++++
Application.EnableEvents = False
'++++++++++++++++++++++++++++++++++++++++
For h = 1 To hCopies
For v = 1 To vCopies
If h = 1 And v = 1 Then GoTo NextV 'first copy is already present!
Application.StatusBar = "Copying to Row " & v & ", Column " & h & "..."
If CopyRange = True Then
'Copy the Cells
Set cell1 = ws.Cells(rng.Row + (v - 1) * vOffset, rng.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng.Rows.Count - 1, cell1.Column + rng.Columns.Count - 1)
Set rng2 = ws.Range(cell1, cell2)
rng.Copy Destination:=rng2
'Resize the columns
If v = 1 Then
For c = rng.Column To (rng.Column + rng.Columns.Count - 1)
ws.Cells(1, c + (h - 1) * hOffset).ColumnWidth = ws.Cells(1, c).ColumnWidth
Next
End If
End If
If CopyChart = True Then
'Copy the Charts
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
chrt.Parent.Activate
chrt.ChartArea.Select
chrt.ChartArea.Copy
ActiveWindow.Visible = False
ws.Cells(1, 1).Select
ActiveSheet.Paste
If CopyRange = True Then
ActiveChart.Parent.Left = rng2.Left + chrtHOffsets(x)
ActiveChart.Parent.Top = rng2.Top + chrtVOffsets(x)
Else
ActiveChart.Parent.Left = chrt.Parent.Left + (h - 1) * chrtHOffsets(x)
ActiveChart.Parent.Top = chrt.Parent.Top + (v - 1) * chrtVOffsets(x)
End If
'Update the Chart Title
If chrtTitles(x) Is Nothing Then
'Do nothing
Else
Set rngWS = chrtTitles(x).Worksheet
Set titleCell = rngWS.Cells(chrtTitles(x).Row + (v - 1) * vOffset, chrtTitles(x).Column + (h - 1) * hOffset)
newTitle = "=" & titleCell.Worksheet.Name & "!R" & titleCell.Row & "C" & titleCell.Column
ActiveChart.ChartTitle.Text = newTitle
End If
For Each ser In ActiveChart.SeriesCollection
oldFormula = ser.Formula
'Check the Series Name
Select Case Mid(oldFormula, 9, 1)
Case Is = ","
'Series Name is Blank (we won't change it)
old1 = ""
new1 = ""
lastChar = 9
Case Is = Chr(34)
'Series Name is a string (we won't change it)
foundEnd = False
firstChar = 9
lastChar = firstChar
Do While foundEnd = False
lastChar = InStr(lastChar + 1, oldFormula, Chr(34))
If Mid(oldFormula, lastChar + 1, 1) = "," Then
foundEnd = True
Else
lastChar = InStr(lastChar + 1, oldFormula, Chr(34))
End If
Loop
old1 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
new1 = old1
lastChar = lastChar + 1
Case Else
'Series Name is a Named or Unnamed Range
firstChar = 9
lastChar = InStr(firstChar + 1, oldFormula, ",") - 1
old1 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
If InStr(old1, "$") = 0 Then
'Series Name is Named Range (we won't change it)
new1 = old1
Else
'Series Name is an Unnamed Range (we WILL change it)
y = InStr(old1, "!")
Set rng3 = ws.Range(Mid(old1, y + 1))
Set cell1 = ws.Cells(rng3.Row + (v - 1) * vOffset, _
rng3.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng3.Rows.Count - 1, cell1.Column + rng3.Columns.Count - 1)
new1 = Left(old1, y) & "R" & cell1.Row & "C" & cell1.Column & ":" & _
"R" & cell2.Row & "C" & cell2.Column
End If
lastChar = lastChar + 1
End Select
'Check the X Values
Select Case Mid(oldFormula, lastChar + 1, 1)
Case Is = ","
'X Values are Blank (we won't change them)
old2 = ""
new2 = ""
lastChar = lastChar + 1
Case Is = "{"
'X Values are in an array (we won't change them)
y = InStr(lastChar + 2, oldFormula, "}")
old2 = Mid(oldFormula, lastChar + 1, y - (lastChar + 1) + 1)
new2 = old2
lastChar = y + 1
Case Else
'X Values are in a Named or Unnamed Range
firstChar = lastChar + 1
lastChar = InStr(firstChar + 1, oldFormula, ",") - 1
old2 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
If InStr(old2, "$") = 0 Then
'X Values are in a Named Range (we won't change them)
new2 = old2
Else
'X Values are in an Unnamed Range (we WILL change them)
y = InStr(old2, "!")
Set rng3 = ws.Range(Mid(old2, y + 1))
Set cell1 = ws.Cells(rng3.Row + (v - 1) * vOffset, _
rng3.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng3.Rows.Count - 1, cell1.Column + rng3.Columns.Count - 1)
new2 = Left(old2, y) & "R" & cell1.Row & "C" & cell1.Column & ":" & _
"R" & cell2.Row & "C" & cell2.Column
End If
lastChar = lastChar + 1
End Select
'Check the Y Values
Select Case Mid(oldFormula, lastChar + 1, 1)
Case Is = "{"
'Y Values are in an array (we won't change them)
y = InStr(lastChar + 2, oldFormula, "}")
old3 = Mid(oldFormula, lastChar + 1, y - (lastChar + 1) + 1)
new3 = old3
lastChar = y + 1
Case Else
'Y Values are in a Named or Unnamed Range
firstChar = lastChar + 1
lastChar = InStr(firstChar + 1, oldFormula, ",") - 1
old3 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
If InStr(old3, "$") = 0 Then
'Y Values are in a Named Range (we won't change them)
new3 = old3
Else
'Y Values are in an Unnamed Range (we WILL change them)
y = InStr(old3, "!")
Set rng3 = ws.Range(Mid(old3, y + 1))
Set cell1 = ws.Cells(rng3.Row + (v - 1) * vOffset, _
rng3.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng3.Rows.Count - 1, cell1.Column + rng3.Columns.Count - 1)
new3 = Left(old3, y) & "R" & cell1.Row & "C" & cell1.Column & ":" & _
"R" & cell2.Row & "C" & cell2.Column
End If
lastChar = lastChar + 1
End Select
newFormula = "=SERIES(" & new1 & "," & new2 & "," & new3 & Mid(oldFormula, lastChar)
ser.FormulaR1C1 = newFormula
Next
ActiveWindow.Visible = False
Next
End If
Set rng2 = Nothing 'Not sure if this helps, but what the hey?
NextV:
'Clean up
Set cell1 = Nothing
Set cell2 = Nothing
Set ser = Nothing
Set rng3 = Nothing
Set rng2 = Nothing
Set titleCell = Nothing
Set chrt = Nothing
Set rngWS = Nothing
Next
Next
'Clean up
ReDim chrtObjs(0)
Set chrtObj = Nothing
Set chrtWS = Nothing
Set rng = Nothing
'++++++++++++++++++++++++++++++++++++++++
Application.EnableEvents = True
'++++++++++++++++++++++++++++++++++++++++
Application.Calculation = xlCalculationAutomatic
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = True
'++++++++++++++++++++++++++++++++++++++++
Application.StatusBar = "Recalculating..."
ws.Calculate
Set ws = Nothing
Application.StatusBar = False
MsgBox ("Done!")
End Sub
It works great that is for about 100 charts after that it really starts to bog down.
I have tried on excel 2003, 2007, 2010 and even the new excel 2010 64 bit
My pc is a quad core 4GHZ 12 GB DD3+ Ram with liquid cooling
My ram barely even moves (the file is only growing about 1MB per 100) my processor are only running at about 25% -
I have done the usual - turn off screenupdating, calculations and events
is there a stack empty or excel cache or some sort of limit feature I can access or something to stop it from slowing down to a grinding halt?
Below is the Code:
Option Explicit
Option Private Module
Sub CopyRange()
Call CopyData(False, True)
End Sub
Sub CopyChart()
Call CopyData(True, False)
End Sub
Sub CopyChartAndRange()
Call CopyData(True, True)
End Sub
Sub CopyData(ByVal CopyChart As Boolean, ByVal CopyRange As Boolean)
'****************************************
Dim wb As Workbook
Dim response As Integer
Dim chrt As Chart
Dim chrtObjs() As ChartObject
Dim selObj As Variant
Dim chrtObj As ChartObject
Dim chrtWS As Worksheet
Dim chrtMessage As String
Dim rng As Range
Dim rngWS As Worksheet
Dim ws As Worksheet
Dim chrtTitles() As Range
Dim foundTitle As Boolean
Dim titleRow As Long
Dim titleCell As Range
Dim hCopies, vCopies As Integer
Dim hOffset, vOffset As Long
Dim chrtHOffsets(), chrtVOffsets() As Double
Dim h, v As Integer
Dim cell1, cell2 As Range
Dim rng2 As Range
Dim c As Long
Dim c1, c2, r1, r2 As Long
Dim wdth, hght As Double
Dim newChrt As Chart
Dim newTitle As String
Dim ser As Series
Dim oldFormula As String
Dim newFormula As String '(R1C1 format)
Dim rng3 As Range
Dim firstChar, lastChar As Integer
Dim foundEnd As Boolean
Dim old1, old2, old3 As String
Dim new1, new2, new3 As String
Dim x, y As Integer
'****************************************
Set wb = Nothing
On Error Resume Next
Set wb = ActiveWorkbook
On Error GoTo 0
If wb Is Nothing Then
ShowError ("You must have an active workbook to use this tool.")
Exit Sub
End If
Set ws = Nothing
ReDim chrtObjs(0)
ReDim chrtTitles(0)
ReDim chrtHOffsets(0)
ReDim chrtVOffsets(0)
If CopyChart = True Then
'See if there is an ActiveChart
Set chrt = Nothing
On Error Resume Next
Set chrt = ActiveChart
On Error GoTo 0
If Not (chrt Is Nothing) Then
ReDim chrtObjs(1)
Set chrtObjs(1) = chrt.Parent
Else
'If no ActiveChart, see if any charts are included in the current Selection
For Each selObj In Selection
Set chrtObj = Nothing
On Error Resume Next
Set chrtObj = selObj
On Error GoTo 0
If chrtObj Is Nothing Then
GoTo NextSelectedObject
Else
ReDim Preserve chrtObjs(UBound(chrtObjs) + 1)
Set chrtObjs(UBound(chrtObjs)) = selObj
End If
NextSelectedObject:
Next
End If
If UBound(chrtObjs) = 0 Then
ShowError ("Please select a chart to copy first.")
Exit Sub
End If
If UBound(chrtObjs) = 1 Then
chrtMessage = "the chart"
Else
chrtMessage = "one of the charts"
End If
Set chrtWS = ActiveSheet
End If
If CopyRange = True Then
Set rng = Nothing
Application.DisplayAlerts = False
On Error Resume Next
Set rng = Application.InputBox(Prompt:="Select the Range to Copy:", _
title:="Microsoft Excel", _
Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rng Is Nothing Then Exit Sub
Set rngWS = rng.Worksheet
End If
If CopyChart = True And CopyRange = True Then
'Check to make sure range and chart are on the same worksheet
If chrtWS.Name <> rngWS.Name Then
ShowError ("Range must be on the same worksheet as the selected chart(s).")
Exit Sub
End If
End If
If CopyChart = True Then
Set ws = chrtWS
Else
Set ws = rngWS
End If
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtTitles(x)
Set chrtTitles(x) = Nothing
If chrt.HasTitle = True Then
foundTitle = False
If CopyRange = True Then
For y = rng.Column To (rng.Column + rng.Columns.Count - 1)
Set cell1 = ws.Cells(rng.Row, y)
Set cell2 = ws.Cells(rng.Row + rng.Rows.Count - 1, y)
Set rng2 = ws.Range(cell1, cell2)
If Not (IsError(Application.Match(chrt.ChartTitle.Text, rng2, 0))) Then
titleRow = Application.Match(chrt.ChartTitle.Text, rng2, 0)
Set titleCell = ws.Cells(titleRow, y)
response = MsgBox("It appears as if " & chrtMessage & " has" & vbCr & _
"a title linked to cell " & titleCell.Address & vbCr & _
"(" & titleCell.Value & ")." & vbCr & _
vbCr & _
"Is this correct?", _
vbYesNoCancel + vbQuestion, _
"Microsoft Excel")
If response = vbCancel Then Exit Sub
If response = vbYes Then
Set chrtTitles(x) = titleCell
foundTitle = True
End If
End If
Next
End If
If foundTitle = False Then
response = MsgBox("Is the title of the chart '" & chrt.ChartTitle.Text & "'" & vbCr & _
"linked to a Cell?", _
vbYesNoCancel, _
"Microsoft Excel")
If response = vbCancel Then Exit Sub
If response = vbYes Then
Set rng2 = Nothing
Application.DisplayAlerts = False
On Error Resume Next
Set rng2 = Application.InputBox(Prompt:="Select the Cell with the Chart's Title:", _
title:="Microsoft Excel", _
Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rng2 Is Nothing Then Exit Sub
If rng2.Rows.Count > 1 Or rng2.Columns.Count > 1 Then
ShowError ("Range for Chart Title must be a single cell!")
Exit Sub
End If
Set chrtTitles(x) = rng2
End If
End If
End If
Next
hCopies = 0
Application.DisplayAlerts = False
On Error Resume Next
hCopies = Application.InputBox(Prompt:="Number of Copies Across:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If hCopies = 0 Then Exit Sub
If (hCopies < 1) Or (Int(hCopies) <> hCopies) Then
ShowError ("Copies Across must be a whole number greater than 0.")
Exit Sub
End If
vCopies = 0
Application.DisplayAlerts = False
On Error Resume Next
vCopies = Application.InputBox(Prompt:="Number of Copies Down:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If vCopies = 0 Then Exit Sub
If (vCopies < 1) Or (Int(vCopies) <> vCopies) Then
ShowError ("Copies Down must be a whole number greater than 0.")
Exit Sub
End If
If hCopies = 1 And vCopies = 1 Then
ShowError ("1 Copy Across x 1 Copy Down = Nothing to Copy!")
Exit Sub
End If
hOffset = 0
If hCopies > 1 Then
Application.DisplayAlerts = False
On Error Resume Next
hOffset = Application.InputBox(Prompt:="Number of Columns to Offset Right:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If hOffset = 0 Then Exit Sub
If (hOffset < 1) Or (Int(hOffset) <> hOffset) Then
ShowError ("Columns to Offset must be a whole number greater than 0.")
Exit Sub
End If
If CopyRange = True Then
If hOffset < rng.Columns.Count Then
ShowError ("This would copy the range partly onto itself!")
Exit Sub
End If
End If
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtHOffsets(x)
If CopyRange = True Then
chrtHOffsets(x) = chrt.Parent.Left - rng.Left
If ws.Cells(1, rng.Column + hOffset).Left + chrtHOffsets(x) < _
chrt.Parent.Left + chrt.Parent.Width Then GoTo ChartHOffsetError
Else
'Find which column the chart starts in
c1 = 1
Do While ws.Cells(1, c1 + 1).Left < chrt.Parent.Left
c1 = c1 + 1
Loop
'Calculate the first column with the offset
c2 = c1 + hOffset
'Calculate the actual offset
chrtHOffsets(x) = ws.Cells(1, c2).Left - ws.Cells(1, c1).Left
'Make sure the column offset is wide enough
If chrtHOffsets(x) < chrt.Parent.Width Then
ChartHOffsetError:
If UBound(chrtObjs) = 1 Then
ShowError ("This would copy the chart partly onto itself!")
Else
ShowError ("This would copy one of the charts partly onto itself!")
End If
Exit Sub
End If
End If
Next
End If
Else
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtHOffsets(x)
If CopyRange = True Then
chrtHOffsets(x) = chrt.Parent.Left - rng.Left
Else
chrtHOffsets(x) = 0
End If
Next
End If
End If
If vCopies > 1 Then
Application.DisplayAlerts = False
On Error Resume Next
vOffset = Application.InputBox(Prompt:="Number of Rows to Offset Down:", _
title:="Microsoft Excel", _
Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If vOffset = 0 Then Exit Sub
If (vOffset < 1) Or (Int(vOffset) <> vOffset) Then
ShowError ("Rows to Offset must be a whole number greater than 0.")
Exit Sub
End If
If CopyRange = True Then
If vOffset < rng.Rows.Count Then
ShowError ("This would copy the range partly onto itself!")
Exit Sub
End If
End If
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtVOffsets(x)
If CopyRange = True Then
chrtVOffsets(x) = chrt.Parent.Top - rng.Top
If ws.Cells(rng.Row + vOffset, 1).Top + chrtVOffsets(x) < _
chrt.Parent.Top + chrt.Parent.Height Then GoTo ChartVOffsetError
Else
'Find which row the chart starts in
r1 = 1
Do While ws.Cells(r1 + 1, 1).Top < chrt.Parent.Top
r1 = r1 + 1
Loop
'Calculate the first row with the offset
r2 = r1 + vOffset
'Calculate the actual offset
chrtVOffsets(x) = ws.Cells(r2, 1).Top - ws.Cells(r1, 1).Top
'Make sure the row offset is high enough
If chrtVOffsets(x) < chrt.Parent.Height Then
ChartVOffsetError:
If UBound(chrtObjs) = 1 Then
ShowError ("This would copy the chart partly onto itself!")
Else
ShowError ("This would copy one of the charts partly onto itself!")
End If
Exit Sub
End If
End If
Next
End If
Else
If CopyChart = True Then
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
ReDim Preserve chrtVOffsets(x)
If CopyRange = True Then
chrtVOffsets(x) = chrt.Parent.Top - rng.Top
Else
chrtVOffsets(x) = 0
End If
Next
End If
End If
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++
Application.Calculation = xlCalculationManual
'++++++++++++++++++++++++++++++++++++++++
Application.EnableEvents = False
'++++++++++++++++++++++++++++++++++++++++
For h = 1 To hCopies
For v = 1 To vCopies
If h = 1 And v = 1 Then GoTo NextV 'first copy is already present!
Application.StatusBar = "Copying to Row " & v & ", Column " & h & "..."
If CopyRange = True Then
'Copy the Cells
Set cell1 = ws.Cells(rng.Row + (v - 1) * vOffset, rng.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng.Rows.Count - 1, cell1.Column + rng.Columns.Count - 1)
Set rng2 = ws.Range(cell1, cell2)
rng.Copy Destination:=rng2
'Resize the columns
If v = 1 Then
For c = rng.Column To (rng.Column + rng.Columns.Count - 1)
ws.Cells(1, c + (h - 1) * hOffset).ColumnWidth = ws.Cells(1, c).ColumnWidth
Next
End If
End If
If CopyChart = True Then
'Copy the Charts
For x = 1 To UBound(chrtObjs)
Set chrt = chrtObjs(x).Chart
chrt.Parent.Activate
chrt.ChartArea.Select
chrt.ChartArea.Copy
ActiveWindow.Visible = False
ws.Cells(1, 1).Select
ActiveSheet.Paste
If CopyRange = True Then
ActiveChart.Parent.Left = rng2.Left + chrtHOffsets(x)
ActiveChart.Parent.Top = rng2.Top + chrtVOffsets(x)
Else
ActiveChart.Parent.Left = chrt.Parent.Left + (h - 1) * chrtHOffsets(x)
ActiveChart.Parent.Top = chrt.Parent.Top + (v - 1) * chrtVOffsets(x)
End If
'Update the Chart Title
If chrtTitles(x) Is Nothing Then
'Do nothing
Else
Set rngWS = chrtTitles(x).Worksheet
Set titleCell = rngWS.Cells(chrtTitles(x).Row + (v - 1) * vOffset, chrtTitles(x).Column + (h - 1) * hOffset)
newTitle = "=" & titleCell.Worksheet.Name & "!R" & titleCell.Row & "C" & titleCell.Column
ActiveChart.ChartTitle.Text = newTitle
End If
For Each ser In ActiveChart.SeriesCollection
oldFormula = ser.Formula
'Check the Series Name
Select Case Mid(oldFormula, 9, 1)
Case Is = ","
'Series Name is Blank (we won't change it)
old1 = ""
new1 = ""
lastChar = 9
Case Is = Chr(34)
'Series Name is a string (we won't change it)
foundEnd = False
firstChar = 9
lastChar = firstChar
Do While foundEnd = False
lastChar = InStr(lastChar + 1, oldFormula, Chr(34))
If Mid(oldFormula, lastChar + 1, 1) = "," Then
foundEnd = True
Else
lastChar = InStr(lastChar + 1, oldFormula, Chr(34))
End If
Loop
old1 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
new1 = old1
lastChar = lastChar + 1
Case Else
'Series Name is a Named or Unnamed Range
firstChar = 9
lastChar = InStr(firstChar + 1, oldFormula, ",") - 1
old1 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
If InStr(old1, "$") = 0 Then
'Series Name is Named Range (we won't change it)
new1 = old1
Else
'Series Name is an Unnamed Range (we WILL change it)
y = InStr(old1, "!")
Set rng3 = ws.Range(Mid(old1, y + 1))
Set cell1 = ws.Cells(rng3.Row + (v - 1) * vOffset, _
rng3.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng3.Rows.Count - 1, cell1.Column + rng3.Columns.Count - 1)
new1 = Left(old1, y) & "R" & cell1.Row & "C" & cell1.Column & ":" & _
"R" & cell2.Row & "C" & cell2.Column
End If
lastChar = lastChar + 1
End Select
'Check the X Values
Select Case Mid(oldFormula, lastChar + 1, 1)
Case Is = ","
'X Values are Blank (we won't change them)
old2 = ""
new2 = ""
lastChar = lastChar + 1
Case Is = "{"
'X Values are in an array (we won't change them)
y = InStr(lastChar + 2, oldFormula, "}")
old2 = Mid(oldFormula, lastChar + 1, y - (lastChar + 1) + 1)
new2 = old2
lastChar = y + 1
Case Else
'X Values are in a Named or Unnamed Range
firstChar = lastChar + 1
lastChar = InStr(firstChar + 1, oldFormula, ",") - 1
old2 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
If InStr(old2, "$") = 0 Then
'X Values are in a Named Range (we won't change them)
new2 = old2
Else
'X Values are in an Unnamed Range (we WILL change them)
y = InStr(old2, "!")
Set rng3 = ws.Range(Mid(old2, y + 1))
Set cell1 = ws.Cells(rng3.Row + (v - 1) * vOffset, _
rng3.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng3.Rows.Count - 1, cell1.Column + rng3.Columns.Count - 1)
new2 = Left(old2, y) & "R" & cell1.Row & "C" & cell1.Column & ":" & _
"R" & cell2.Row & "C" & cell2.Column
End If
lastChar = lastChar + 1
End Select
'Check the Y Values
Select Case Mid(oldFormula, lastChar + 1, 1)
Case Is = "{"
'Y Values are in an array (we won't change them)
y = InStr(lastChar + 2, oldFormula, "}")
old3 = Mid(oldFormula, lastChar + 1, y - (lastChar + 1) + 1)
new3 = old3
lastChar = y + 1
Case Else
'Y Values are in a Named or Unnamed Range
firstChar = lastChar + 1
lastChar = InStr(firstChar + 1, oldFormula, ",") - 1
old3 = Mid(oldFormula, firstChar, lastChar - firstChar + 1)
If InStr(old3, "$") = 0 Then
'Y Values are in a Named Range (we won't change them)
new3 = old3
Else
'Y Values are in an Unnamed Range (we WILL change them)
y = InStr(old3, "!")
Set rng3 = ws.Range(Mid(old3, y + 1))
Set cell1 = ws.Cells(rng3.Row + (v - 1) * vOffset, _
rng3.Column + (h - 1) * hOffset)
Set cell2 = ws.Cells(cell1.Row + rng3.Rows.Count - 1, cell1.Column + rng3.Columns.Count - 1)
new3 = Left(old3, y) & "R" & cell1.Row & "C" & cell1.Column & ":" & _
"R" & cell2.Row & "C" & cell2.Column
End If
lastChar = lastChar + 1
End Select
newFormula = "=SERIES(" & new1 & "," & new2 & "," & new3 & Mid(oldFormula, lastChar)
ser.FormulaR1C1 = newFormula
Next
ActiveWindow.Visible = False
Next
End If
Set rng2 = Nothing 'Not sure if this helps, but what the hey?
NextV:
'Clean up
Set cell1 = Nothing
Set cell2 = Nothing
Set ser = Nothing
Set rng3 = Nothing
Set rng2 = Nothing
Set titleCell = Nothing
Set chrt = Nothing
Set rngWS = Nothing
Next
Next
'Clean up
ReDim chrtObjs(0)
Set chrtObj = Nothing
Set chrtWS = Nothing
Set rng = Nothing
'++++++++++++++++++++++++++++++++++++++++
Application.EnableEvents = True
'++++++++++++++++++++++++++++++++++++++++
Application.Calculation = xlCalculationAutomatic
'++++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = True
'++++++++++++++++++++++++++++++++++++++++
Application.StatusBar = "Recalculating..."
ws.Calculate
Set ws = Nothing
Application.StatusBar = False
MsgBox ("Done!")
End Sub
