Consulting

Results 1 to 3 of 3

Thread: macro loop through 2 worksheets

  1. #1
    VBAX Contributor
    Joined
    Apr 2012
    Posts
    107
    Location

    macro loop through 2 worksheets

    After applying macro on Sheet1,go to Sheet2 and to apply the same macro but starting from 'Set cht1 = ActiveSheet.Shapes.AddChart'
    plse add code
    [VBA]Dim lastrow As Long
    Dim selectnum As Long
    lastrow = Cells(Rows.Count, "a").End(xlUp).Row
    Select Case True
    Case lastrow > 30: selectnum = 30
    Case lastrow > 20: selectnum = 20
    Case lastrow > 10: selectnum = lastrow
    End Select
    Cells(lastrow - selectnum + 1, "a").Resize(selectnum, 3).Select
    Set cht1 = ActiveSheet.Shapes.AddChart
    cht1.Chart.ChartType = xlLineMarkers
    cht1.Chart.Location xlLocationAsNewSheet
    ActiveChart.ChartArea.Select
    ActiveChart.PlotArea.Select
    , plse add code[/VBA]
    Attached Files Attached Files
    Last edited by Bob Phillips; 05-09-2012 at 03:13 AM. Reason: Tidied up code

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,453
    Location
    [VBA]Public Sub CreateAllCharte()
    Call CreateChart(Worksheets("Sheet1"))
    Call CreateChart(Worksheets("Sheet2"))
    End Sub

    Private Sub CreateChart(ByRef sh As Worksheet)
    Dim cht As Object
    Dim lastrow As Long
    Dim selectnum As Long

    With sh

    .Select
    lastrow = .Cells(.Rows.Count, "a").End(xlUp).Row
    Select Case True
    Case lastrow > 30: selectnum = 30
    Case lastrow > 20: selectnum = 20
    Case lastrow > 10: selectnum = lastrow
    End Select
    .Cells(lastrow - selectnum + 1, "a").Resize(selectnum, 3).Select
    Set cht = .Shapes.AddChart
    cht.Chart.ChartType = xlLineMarkers
    cht.Chart.Location xlLocationAsNewSheet
    End With

    ActiveChart.ChartArea.Select
    ActiveChart.PlotArea.Select
    End Sub
    [/VBA]
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    VBAX Contributor
    Joined
    Apr 2012
    Posts
    107
    Location

    macro loop through 2 worksheets

    Thank you for your vba. I tried the following vba but not working:
    [vba]Public Sub CreateAllCharte()
    Call CreateChart(Worksheets("Sheet1"))
    Call CreateChart(Worksheets("Sheet2"))
    End Sub
    Private Sub CreateChart(ByRef sh As Worksheet)

    Sheets("Sheet1").Select
    Range("A2").Select
    ActiveSheet.Paste
    Columns("E:E").Select
    Selection.Copy
    Columns("B:B").Select
    ActiveSheet.Paste
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Columns("A:B").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    ActiveSheet.Paste
    Dim i As Long, rng As Range
    Columns(1).Insert
    With Range("b2", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
    .Formula = "=if(and(weekday(b2,2)<weekday(b3,2),b3<>""""),1,"""")"
    .Value = .Value
    On Error Resume Next
    .SpecialCells(2, 1).EntireRow.Delete
    On Error GoTo 0
    End With
    Columns(1).Delete

    With sh
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "=(R[-3]C2)*2-R[-6]C2"
    Dim Lt As Long
    Lt = Range("b2").End(xlDown).Offset(3, 0).Row
    Selection.AutoFill Destination:=Range("c8:c" & Lt), Type:=xlFillDefault
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "=ROUND(AVERAGE(R[4]C[-2]:R[6]C[-2]),3)"
    Range("D4").Select
    Selection.AutoFill Destination:=Range("D435"), Type:=xlFillDefault
    Range("D435").Select
    Range("E5").Select
    ActiveCell.FormulaR1C1 = "=ROUND(AVERAGE(R[-3]C[-3]:R[1]C[-3]),5)"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "=ROUND(AVERAGE(R[-2]C[-2]:RC[-2]),3)"
    Range("D4").Select
    Selection.AutoFill Destination:=Range("D435"), Type:=xlFillDefault
    Range("D435").Select
    Range("E5").Select
    ActiveCell.FormulaR1C1 = "=ROUND(AVERAGE(R[-3]C[-3]:R[1]C[-3]),5)"
    Range("E5").Select
    ActiveCell.FormulaR1C1 = ""
    Range("E6").Select
    ActiveCell.FormulaR1C1 = "=ROUND(AVERAGE(R[-4]C[-3]:RC[-3]),5)"
    Range("E6").Select
    Selection.AutoFill Destination:=Range("E6:E35"), Type:=xlFillDefault
    Range("E6:E35").Select
    Columns("D:E").Select
    Selection.NumberFormat = "0.000"
    Range("F11").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-4]<RC[-2],3,0)"
    Range("F11").Select
    Selection.AutoFill Destination:=Range("F11:F35"), Type:=xlFillDefault
    Range("F11:F35").Select
    Range("G11").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]<RC[-2],5,0)"
    Range("G11").Select
    Selection.AutoFill Destination:=Range("G11:G34"), Type:=xlFillDefault
    Range("G11:G34").Select
    Columns("A:A").ColumnWidth = 10
    With Range("A" & Rows.Count).End(xlUp)
    .AutoFill .Resize(4)

    Dim cht As Object
    Dim cht1 As Object
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "=(R[-3]C2)*2-R[-6]C2"
    Range("C8").Select
    Selection.AutoFill Destination:=Range("C8:C50"), Type:=xlFillDefault
    Range("C8:C50").Select
    With Range("A" & Rows.Count).End(xlUp)
    .AutoFill .Resize(4)

    Dim lastrow As Long
    Dim selectnum As Long
    lastrow = Range("B2").End(xlDown).Offset(3, 0).Row
    Select Case True
    Case lastrow > 30: selectnum = 30
    Case lastrow > 20: selectnum = 20
    Case lastrow > 10: selectnum = lastrow
    End Select
    Cells(lastrow - selectnum + 1, "A").Resize(selectnum, 3).Select
    Set cht1 = ActiveSheet.Shapes.AddChart
    cht1.chart.ChartType = xlLineMarkers
    cht1.chart.Location xlLocationAsNewSheet
    ActiveChart.ChartArea.Select
    ActiveChart.PlotArea.Select

    Dim ValuesArray(), SeriesValues As Variant
    Dim Ctr As Integer, TotCtr As Integer
    With ActiveChart
    For Each x In .SeriesCollection
    SeriesValues = x.Values
    ReDim Preserve ValuesArray(1 To TotCtr + UBound(SeriesValues))
    For Ctr = 1 To UBound(SeriesValues)
    ValuesArray(Ctr + TotCtr) = SeriesValues(Ctr)
    Next
    TotCtr = TotCtr + UBound(SeriesValues)
    Next
    .Axes(xlValue).MinimumScaleIsAuto = True
    .Axes(xlValue).MaximumScaleIsAuto = True
    .Axes(xlValue).MinimumScale = Application.Min(ValuesArray)
    .Axes(xlValue).MaximumScale = Application.Max(ValuesArray)
    End With
    End With
    End With
    End With
    End Sub[/vba]
    Attached Images Attached Images

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •