Problem vid skapande av diagram med vba

[Riker]

Jag har ett makro (i filen Data.xlsm) som skapar en ny sida i en annan workbook, kallad HM.xlsx och kopierar över data från vissa celler.

Därefter skall makrot rita upp ett diagram på samma sida i HM.xlsx, men det är här problemmet uppstår.

Jag skapade ett makro genom att använda excels makro inspelnings funktion, och när jag kör denna kod separat så fungerar den inspelad makrot.

Tyvärr så blir diagrammet felaktigt när jag kopierar över koden och anpassar den till min kod.

Jag bifogar 2 bilder, bild1 visar hur diagrammet skall se ut och bild2 hur den ser ut när jag använder koden i mitt skript.

 

Jag vore tacksam om någon som kan excel och vba kollar och ser om de hittar vad jag gjort för fel, mina excel kunskaper är inte så bra.

 

Om någon vill så kan jag även biffoga de 2 filerna.

HM.xlsx är en tom arbetsbok som inte innehåller någon kod, utan där skall data med diagram samlas.

Här är ialla fall hela koden från Data.xlsm:

 

Option Explicit
Sub Kontrollprov()
   Dim strPath As String
   Dim wbK As Workbook
   Dim wbM As Workbook
   Dim ProvID As String
   Dim PasteFrom As String
   Dim PasteTo As String
   Dim PasteStr As String
   Dim Rad As Integer
   Dim Mätvärden() As Integer
   Dim Ant As Integer
   Dim Pos As Integer
   Dim wsBlad As Worksheet

    On Error Resume Next
     Set wbM = Workbooks("HM.xlsx")
   Set wbK = ThisWorkbook                      ' Kontrollprovs ark
   If Err Then
       MsgBox "An error occured!", vbExclamation, ""
       Exit Sub
   End If

   Rad = 11
   Ant = 0

   Set wsBlad = wbK.Worksheets("blad1")
   wbK.Activate
   ProvID = Cells(6, 2).Value
   Pos = InStr(1, ProvID, " ")
   ProvID = Left(ProvID, Pos - 1)

   'Exit Sub
   While Cells(Rad, 3).Value <> ""
       Ant = Ant + 1
       ReDim Preserve Mätvärden(Ant)
       Mätvärden(Ant) = Cells(Rad, 3).Value
       Rad = Rad + 1
   Wend
   Rad = Rad - 1
   wbM.Activate
   If Not DoesSheetExist(ProvID) Then  ' KCheck to see if sheet exists, if not create it
       MsgBox "An error occured!", vbInformation, ""
       Exit Sub
   End If

   MergeWS wbK, wbM, ProvID
End Sub

Function DoesSheetExist(blad As String) As Boolean

'''''''''''''''''''''''''''''''''''''

'Written by [url="http://www.ozgrid.com/"]www.OzGrid.com[/url]
'Test to see if a Worksheet exists.

'''''''''''''''''''''''''''''''''''''

   Dim wSheet As Worksheet

   On Error Resume Next

   Set wSheet = Sheets(blad)

       If wSheet Is Nothing Then 'Doesn't exist

           ' Create sheet
           Worksheets.Add: ActiveSheet.Name = blad


           Set wSheet = Nothing

           On Error GoTo ErrorGen
           DoesSheetExist = True
       Else 'It does exist

           Set wSheet = Nothing
           DoesSheetExist = True

       End If
       Exit Function
ErrorGen:
   DoesSheetExist = False
End Function

Sub MergeWS(wbK As Workbook, wbM As Workbook, blad As String)
'
   Dim LastRow As Long
   Dim NextRow As Long, NextRow2 As Long
   Dim Ant As Long
   Dim TotAnt As Long
   Dim cnt As Long
   Dim Tmp As Long

   On Error GoTo ErrorG

   wbM.Worksheets(blad).Activate
   Range("B3").Select
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("B3") = "n"

   'wbM.Worksheets(blad).Activate
   Range("C3").Select
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   ActiveCell.Borders.LineStyle = xlContinuous
   Range("C3") = "Mätvärden"

   wbM.Worksheets(blad).Activate
   Range("I22").Select
   ActiveCell.Font.Name = "Calibri"
   'ActiveCell.Font.Bold = True
   Range("I22") = "n"

   'wbM.Worksheets(blad).Activate
   Range("I23").Select
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("I23") = "Mätvärde"

   ' determine where the data ends on Column C Sheet1
   wbK.Worksheets("blad1").Activate
   Range("C65536").Select
   ActiveCell.End(xlUp).Select 'xlup
   LastRow = ActiveCell.Row

   ' copy the data from Column C in Sheet 1
   Range("C11:C" & LastRow).Copy
   Ant = LastRow - 10

   ' Determine where to add the new data in Column C Sheet 2
   wbM.Worksheets(blad).Activate
   Range("C65536").Select
   ActiveCell.End(xlUp).Offset(1, 0).Select
   NextRow = ActiveCell.Row

   ' paste the data to Column C Sheet 2
   wbM.Worksheets(blad).Range("C" & NextRow).Select
   ActiveSheet.Paste
   Application.CutCopyMode = False

  For cnt = NextRow To (NextRow + Ant - 1)
       Range("B" + CStr(cnt)) = CStr(cnt - 3)   ' CStr(cnt - NextRow + 1)
   Next

   ' Determine where to add the new data in Column C Sheet 2       
   'Range("J65536").Select
   'ActiveCell.End(xlUp).Offset(1, 0).Select
   'NextRow2 = ActiveCell.Row
   For cnt = 10 To (9 + Ant)
       Tmp = Range("C" + CStr(cnt - 6) + ":C" + CStr(cnt - 6)).Value
       Range(Cells(23, cnt), Cells(23, cnt)).Select
       Range(Cells(23, cnt), Cells(23, cnt)) = Tmp
       ActiveCell.Font.Name = "Calibri"
   Next

   ' paste the data to Column C Sheet 2
   'wbM.Worksheets(blad).Range("J" & NextRow2).Select
   'ActiveSheet.Paste
   'Application.CutCopyMode = False

   'For cnt = NextRow To (NextRow + Ant - 1)
   '    Range("I" + CStr(cnt + 19)) = CStr(cnt - 3)
   'Next
   For cnt = 10 To (9 + Ant)
       Range(Cells(22, cnt), Cells(22, Int(9 + Ant))).Select
       ActiveCell.Font.Name = "Calibri"
       Range(Cells(22, cnt), Cells(22, Int(9 + Ant))) = CStr(cnt - 9)
   Next

   wbM.Worksheets(blad).Activate
   Range("C65536").Select
   ActiveCell.End(xlUp).Offset(1, 0).Select
   LastRow = ActiveCell.Row - 1

   Range("C3:C" & LastRow).Select
   With Selection.Borders(xlEdgeLeft)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeRight)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlInsideVertical)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlInsideHorizontal)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   TotAnt = LastRow - 3
   'AddChart wbM, blad, "C4", "C" + CStr(LastRow), TotAnt
   'add_chart wbM, blad, "C4", "C" + CStr(LastRow), "B4", "B" + CStr(LastRow), TotAnt
   'AddChartObject wbM, blad, "C4", "C" + CStr(LastRow)
   'ChartWizard wbM, blad

   On Error GoTo ErrorG
   wbM.Worksheets(blad).Activate
   Range("E22").Select
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("E22") = "Kontrollprov"

   Range("G22").Select
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("G22") = "Sigma"

   Range("H22").Select
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("H22") = "Medel"

   Range("I24").Select             ' K22
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("I24") = "2s_ö"

   Range("I25").Select             ' L22
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("I25") = "2s_u"

   Range("I26").Select             ' M22
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("I26") = "3s_ö"

   Range("I27").Select             ' N22
   ActiveCell.Font.Name = "Calibri"
   ActiveCell.Font.Bold = True
   Range("I27") = "3s_u"

   Range("E23").Select
   ActiveCell.Font.Name = "Calibri"
   Range("E23") = blad

   ' Beräkna sigma ( std. avvikelse)
   Range("G23").Select
   ActiveCell.Font.Name = "Calibri"
   'Range("H23").Formula = "=stdev(C4:C" + CStr(LastRow) + ")"
   Range("G23").Formula = "=round(stdev(C4:C" + CStr(LastRow) + "), 2)"

   Range("H23").Select
   ActiveCell.Font.Name = "Calibri"
   Range("H23").Formula = "=average(C4:C" + CStr(LastRow) + ")"

   Range(Cells(25, 10), Cells(25, Int(9 + TotAnt))).Select
   ActiveCell.Font.Name = "Calibri"
   Range(Cells(25, 10), Cells(25, Int(9 + TotAnt))) = "213,74"       
   Range(Cells(27, 10), Cells(27, Int(9 + TotAnt))).Select            
   ActiveCell.Font.Name = "Calibri"
   Range(Cells(27, 10), Cells(27, Int(9 + TotAnt))) = "211,12"         

   Range(Cells(24, 10), Cells(24, Int(9 + TotAnt))).Select             '
   ActiveCell.Font.Name = "Calibri"
   Range(Cells(24, 10), Cells(24, Int(9 + TotAnt))) = "224,17"         '

   Range(Cells(26, 10), Cells(26, Int(9 + TotAnt))).Select             
   ActiveCell.Font.Name = "Calibri"
   Range(Cells(26, 10), Cells(26, Int(9 + TotAnt))) = "226,78"         

   SkapaDiagram wbM, blad
Exit Sub
ErrorG:
   MsgBox Err.Description, vbInformation, ""
End Sub

Sub SkapaDiagram(wbM As Workbook, blad As String)
   Application.Run "ReleaseCOMPlus"
   ActiveSheet.Shapes.AddChart.Select
   ActiveChart.ChartType = xlLine
   ActiveChart.SetSourceData Source:=Range(blad & "!$I$23:$N$27")
   ActiveSheet.Shapes("Diagram 1").IncrementLeft -53.25
   ActiveSheet.Shapes("Diagram 1").IncrementTop -80.25
   ActiveChart.Legend.Select
   ActiveChart.Legend.LegendEntries(4).Select
   Application.Run "ReleaseCOMPlus"
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.ObjectThemeColor = msoThemeColorAccent1
       .ForeColor.TintAndShade = 0
       .ForeColor.Brightness = 0
   End With
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 0, 0)
       .Transparency = 0
   End With
   ActiveChart.Legend.LegendEntries(2).Select
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 0, 0)
   End With
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 255, 0)
       .Transparency = 0
   End With
   ActiveChart.Legend.LegendEntries(3).Select
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 255, 0)
   End With
   ActiveChart.Legend.LegendEntries(5).Select
   Application.Run "ReleaseCOMPlus"
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 255, 0)
   End With
   With Selection.Format.Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 0, 0)
       .Transparency = 0
   End With
   Application.Run "ReleaseCOMPlus"
End Sub

[Monshi]

Tittar snabbt igenom din kod utan att fästa mig vid detaljer.

 

Ett generellt fel finns, du använder sig av Select, Activate och liknande.

Bort med alla Select-satser är enkla rådet, deklarerar alla variabler är andra rådet.

 

 

Se gärna

//eforum.idg.se/topic/220943-riktlinjer-for-bra-vba-kod/

och återkom sedan med lite städad kod.

[Riker]

Jag lade till ett "Option Explicit" i början av makrot och fixade en variabel som jag missat att deklarera.

 

Felmeddelandet jag får är "Autimation-fel Odefinerat fel", detta genereras på raden "ActiveChart.Legend.LegendEntries(4).Select" i subrutinen "SkapaDiagram

 

Jag skall kolla på att ta bort select satser

[Riker]

Jag skrev om subrutiner efter ett exempel som jag hittade:

 

 Sub EmbeddedChartFromScratch(wbM As Workbook, blad As String)
   Dim myChtObj As ChartObject
   Dim rngChtData As Range
   Dim rngChtXVal As Range
   Dim iColumn As Long

   ' Using the selected range as the chart's data source.
   ' The first row contains the series labels, the first column contains the X values,
   ' and the rest of the columns contain the Y values for each series.

   ' make sure a range is selected
   If TypeName(Selection) <> "Range" Then Exit Sub

   ' define chart data
   Set rngChtData = Selection

   ' define chart's X values
   With rngChtData
       Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 1)
   End With

   ' add the chart
   Set myChtObj = ActiveSheet.ChartObjects.Add(Left:=150, Width:=300, Top:=15, Height:=300)
   With myChtObj.Chart

       ' make an line chart
       .ChartType = xlLine
       .HasLegend = True

       ' remove extra series
       Do Until .SeriesCollection.Count = 0
           .SeriesCollection(1).Delete
       Loop

       ' add series from selected range, column by column
       For iColumn = 2 To rngChtData.Columns.Count
           With .SeriesCollection.NewSeries
               .Values = rngChtXVal.Offset(, iColumn - 1)
               .XValues = rngChtXVal
               .Name = rngChtData(1, iColumn)
           End With
       Next

   End With

End Sub

 

Så här ser diagrammet ut:

 

Hur ändrar jag färgen på legend linjerna (så att jag får det att se ut som i min första post)?

Samt lägger in 'LegendTitle:=blad

samt valuetitle:="Hårdhet"

[Monshi]

Här får du några metoder för att färglägga linjerna

	Dim s As SeriesCollection
With Me.ChartObjects("Diagram 1")
   	With .Chart
       	.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(128, 0, 0)
       	.SeriesCollection(2).Format.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent2
       	.SeriesCollection(3).Format.Line.ForeColor.RGB = RGB(56, 18, 90)
       	.SeriesCollection(4).Format.Line.ForeColor.SchemeColor = 5
       	.SeriesCollection(5).Format.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent5

   	End With
End With

Samt du kan med fördel ändra början av koden till

 

Sub EmbeddedChartFromScratch()
Dim myChtObj As ChartObject
Dim rngChtData As Range
Dim rngChtXVal As Range
Dim iColumn As Long


Dim myRn As Range
Set rngChtData = Application.InputBox("Markera dataområde för graf", "Graf", Type:=8)

If rngChtData Is Nothing Then Exit Sub

[Riker]

Ok, tack för hjälpen. Jag lade in

.        SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(255, 255, 0)
       .SeriesCollection(3).Format.Line.ForeColor.RGB = RGB(255, 255, 0)
       .SeriesCollection(4).Format.Line.ForeColor.RGB = RGB(255, 0, 0)
       .SeriesCollection(5).Format.Line.ForeColor.RGB = RGB(255, 0, 0)

i slutet av subrutinen, före sista "End With" så fungerar det som tänkt, åter igen, tack för hjälpen jag har hållit på länge med detta skript