Code: Select all
Sub PlotCHills()
'
' PlotHills Macro
'
'
Dim initRowPlot As Integer
Dim initCol As Integer
Dim rowNo As Integer
Dim colNo As Integer
Dim dyRow As Integer
Dim dataInitRow As Integer
Dim dataInitCol As Integer
Dim dataRow As Integer
Dim dataCol As Integer
Dim dataDcol As Integer
Dim i As Integer
Dim j As Integer
Dim numPlot As Integer
Dim maxNumList As Integer
Dim maxNumPlot As Integer
Dim lastRow As Integer
Dim dataSheet As String
Dim plotSheet As String
Dim listSheet As String
Dim chartTitle As String
Dim indexWord As String
Dim objCht As ChartObject
Dim objShp As Shape
Dim pgText As TextFrame2
'*********************************************************
'dataSheet = "TestData"
dataSheet = "FormedData"
plotSheet = "CHills-Plot"
plotSample = "PlotTemplate"
listSheet = "TargetList"
maxNumPlot = 200
'*********************************************************
initRowPlot = 2
initCol = 1
dyRow = 37
dxCol = 2
' Clear all contents
Sheets(plotSheet).Select
Sheets(plotSheet).Activate
ActiveSheet.Cells.Clear ' Clear all cells.
For Each objCht In ActiveSheet.ChartObjects ' Remove all charts
objCht.Delete
Next
ActiveSheet.DrawingObjects.Delete ' Remove all drawing objects
' Set column width
Columns("A").ColumnWidth = 1.67
Columns("B:AB").ColumnWidth = 4.43
' Compute the number of data set.
i = 2
numPlot = 0
maxNumList = Sheets(listSheet).Cells(Sheets(listSheet).Rows.Count, 1).End(xlUp).Row
Do While i < maxNumList
indexWord = Sheets(listSheet).Cells(i, 8)
If indexWord = "CH" Then
numPlot = numPlot + 1
End If
i = i + 1
Loop
i = numPlot / 4 ' 4 graphs per page.
If (numPlot > i * 4) Then
maxNumPlot = i + 1
Else
maxNumPlot = i
End If
' Copy the template plot
colNo = 2
For i = 1 To maxNumPlot
rowNo = initRowPlot + (i - 1) * dyRow
Sheets(plotSheet).Select
ActiveSheet.Cells(rowNo, colNo).Select
Sheets(plotSample).Select
ActiveSheet.Shapes.Range(Array("Group 1")).Select
Selection.Copy
Sheets(plotSheet).Select
ActiveSheet.Cells(rowNo, colNo).Select
ActiveSheet.Paste
Next i
ActiveSheet.Range("B1").Select
' Update all observation plot data.
i = 1
j = 2 ' Target list.
Sheets(listSheet).Cells(1, 12) = "CH Plot"
For Each objCht In Worksheets(plotSheet).ChartObjects
ActiveSheet.ChartObjects(objCht.Name).Activate
ActiveChart.chartTitle.Select
chartTitle = ""
indexWord = ""
Do While Not Sheets(listSheet).Cells(j, 8) = "CH"
i = i + 4
j = j + 1
Loop
chartTitle = Sheets(dataSheet).Cells(1, i)
indexWord = Sheets(listSheet).Cells(j, 8)
If Not chartTitle = "" And indexWord = "CH" Then
' Observation data
lastRow = Sheets(dataSheet).Cells(Sheets(dataSheet).Rows.Count, i + 1).End(xlUp).Row
chartTitle = Sheets(dataSheet).Cells(1, i) & " (" & Sheets(listSheet).Cells(j, 7) & " )" _
& "- " & Sheets(listSheet).Cells(j, 5) & "ft (L " & Sheets(listSheet).Cells(j, 6) & ")"
Selection.Characters.Text = chartTitle
Selection.Characters.Font.Size = 11
ActiveChart.chartTitle.Left = ActiveChart.ChartArea.Width
ActiveChart.chartTitle.Left = ActiveChart.chartTitle.Left / 2
Selection.Characters.Text = chartTitle
ActiveChart.SeriesCollection(1).Name = chartTitle
ActiveChart.SeriesCollection(1).XValues = _
Sheets(dataSheet).Range(Sheets(dataSheet).Cells(3, i), Sheets(dataSheet).Cells(lastRow, i))
ActiveChart.SeriesCollection(1).Values = _
Sheets(dataSheet).Range(Sheets(dataSheet).Cells(3, i + 1), Sheets(dataSheet).Cells(lastRow, i + 1))
' Modeled data
lastRow = Sheets(dataSheet).Cells(Sheets(dataSheet).Rows.Count, i + 3).End(xlUp).Row
ActiveChart.SeriesCollection(2).XValues = _
Sheets(dataSheet).Range(Sheets(dataSheet).Cells(3, i + 2), Sheets(dataSheet).Cells(lastRow, i + 2))
ActiveChart.SeriesCollection(2).Values = _
Sheets(dataSheet).Range(Sheets(dataSheet).Cells(3, i + 3), Sheets(dataSheet).Cells(lastRow, i + 3))
' Verify Plot name and Target-list name.
Sheets(listSheet).Cells(j, 12) = "CH"
' Set a minimum for x-axis.
If (WorksheetFunction.Min(ActiveChart.SeriesCollection(1).XValues)) < 0 Then
ActiveChart.Axes(xlCategory).MinimumScale = 0
End If
ActiveChart.Axes(xlCategory).MinimumScale = 0
ActiveChart.Axes(xlCategory).MaximumScale = 7000
ActiveChart.Axes(xlCategory).MajorUnit = 1000
ActiveChart.Axes(xlCategory).TickLabels.NumberFormat = "0" ' Number
' Set minimum & maximum for y-axis.
minY1 = WorksheetFunction.Min(ActiveChart.SeriesCollection(1).Values)
maxY1 = WorksheetFunction.Max(ActiveChart.SeriesCollection(1).Values)
minY2 = WorksheetFunction.Min(ActiveChart.SeriesCollection(2).Values)
maxY2 = WorksheetFunction.Max(ActiveChart.SeriesCollection(2).Values)
If minY1 < minY2 Then
minYaxis = minY1
Else
minYaxis = minY2
End If
If maxY1 > maxY2 Then
maxYaxis = maxY1
Else
maxYaxis = maxY2
End If
diffYaxis = maxYaxis - minYaxis
If diffYaxis < 1000 Then
midYaxis = (maxYaxis + minYaxis) / 2
midYaxis = WorksheetFunction.Round(midYaxis / 100, 0) * 100
maxYaxis = midYaxis + 500
minYaxis = midYaxis - 500
Else
maxYaxis = WorksheetFunction.Round(maxYaxis / 100, 0) * 100 + 100
minYaxis = WorksheetFunction.Round(minYaxis / 100, 0) * 100 - 100
End If
ActiveChart.Axes(xlValue).MinimumScale = minYaxis
ActiveChart.Axes(xlValue).MaximumScale = maxYaxis
ActiveChart.Axes(xlValue).TickLabels.NumberFormat = "0" ' Number
Else
ActiveSheet.ChartObjects(objCht.Name).Delete
End If
i = i + 4
j = j + 1
Next
ActiveSheet.Range("B1").Select
' Update page numbers on the plots.
i = 0
For Each objShp In Worksheets(plotSheet).Shapes
i = i + 1
Set pgText = ActiveSheet.Shapes(objShp.Name).GroupItems("PageNo").TextFrame2
pgText.TextRange.Characters.Text = "Page " & CStr(i) & " of " & CStr(maxNumPlot)
Set pgText = ActiveSheet.Shapes(objShp.Name).GroupItems("FigNo").TextFrame2
pgText.TextRange.Characters.Text = "CHills"
Next
ActiveSheet.Range("AA1").Select
End Sub