Diagramm mit nicht zusammenhängenden Zellen erstellen

[Günti]

Hallo,

ich möchte ein Script erstellen um ein Diagramm zu erstellen.
Die Zellen mit denen die Säulen erstellt werden sollen, liegen 
alle in einer Zeile.

Der Name liegt in Zelle A2 und der dazugehörige Wert in B2.
Die nächste Säule soll direkt neben der ersten als Vergleichswert liegen.
Der Name dieser Säule liegt in Zelle D2 und der Wert in E2.

Die Tabelle hänge ich an.
Hat mir jemand einen Tip.

Danke und Gruß
Günti

[WillWissen]

Push!!

[Günti]

Hallo,

ich habe die Lösung für dieses Problem gefunden.


Aber wie kann ich auf Tabelle 2 nach jeder zweiten Zeile eine Leerzeile einfügen ?

Danke im voraus und Gruß
Günti

Code:

Sub prcForm_Excel_Dateien_einlesen()
 Dim lngC As Long, lngA As Long
 Dim strPath As String
 Dim strDatei As String
 Dim vntZellAdressen As Variant
 
 Dim LastRow As Long
 Dim Rng1 As Range
 Dim Rng2 As Range
 Dim Rng3 As Range
 Dim Rng4 As Range
 Dim ShName As String
 
 lngC = 1
 vntZellAdressen = Array("A2", "B2", "A3", "B3")
 strPath = "C:\PG500\Inf-Files\"
 strDatei = Dir(strPath & "*.xlsx")
 
 Do While strDatei <> ""
    Workbooks.Open (strPath & strDatei)
    For lngA = 0 To UBound(vntZellAdressen)
       ActiveWorkbook.Worksheets(3).Range(vntZellAdressen(lngA)).Copy ThisWorkbook.Worksheets(1).Cells(lngC, lngA + 1)
    Next lngA
   lngC = lngC + 1
       
    ActiveWorkbook.Close False
    strDatei = Dir
 Loop
 
   'Erste Zeile einfügen
   Rows(r + 1).Insert Shift:=xlDown
   
   'Spalten beschriften
   Range("A1").Select
   ActiveCell.FormulaR1C1 = "Prüfauftrag Monat A"
   Range("B1").Select
   ActiveCell.FormulaR1C1 = "Yield Monat A in %"
   Range("C1").Select
   ActiveCell.FormulaR1C1 = "Prüfauftrag Monat B"
   Range("D1").Select
   ActiveCell.FormulaR1C1 = "Yield Monat B in %"
   
 
  'Anpassung der Spaltenbreite
   Call ActiveSheet.Columns.AutoFit
 
   'Arbeitsblatt umbenennen
   ThisWorkbook.Worksheets(1).Name = "Yieldauswertung"
   
   
   'Auflistung der Prüfmonate
   Dim wksQ As Worksheet
   Dim wksZ As Worksheet
   Dim lngZ As Long
   Dim lngZZ As Long
   Dim intS As Integer

   Set wksQ = Worksheets(1) 'Quellblatt
   Set wksZ = Worksheets(2) 'Zielblatt
   lngZZ = 2

   With wksQ
   For lngZ = 2 To .Range("A100").End(xlUp).Row
   
     
   wksZ.Cells(lngZZ, 1).Value = wksQ.Cells(lngZ, 1).Value
   wksZ.Cells(lngZZ, 2).Value = wksQ.Cells(lngZ, 2).Value
   
   lngZZ = lngZZ + 1
   
   wksZ.Cells(lngZZ, 1).Value = wksQ.Cells(lngZ, 3).Value
   wksZ.Cells(lngZZ, 2).Value = wksQ.Cells(lngZ, 4).Value
           
   lngZZ = lngZZ + 1
       
 
  Next

End With

 
 
   
   'Auf Tabelle2 (Blatt2) wechseln
   Sheets("Tabelle2").Activate
   
   'Zahlenformat festlegen
   Range("B1:B300").NumberFormat = "#,##0.00"
     
   'Letzte Zeile suchen und Diagrammbereich in Variable schreiben
   With ActiveSheet
       LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
       Set Rng1 = .Range("A2:B" & LastRow)
                     
       ShName = .Name
   End With
   
     
   
   'Diagramm einfügen
   Charts.Add
   
   
   With ActiveChart
       .ChartType = xlColumnClustered
       .SetSourceData Source:=Rng1
             
       
       'Beschriftung Diagramm
           '.HasTitle = True
       
           .SetElement (msoElementChartTitleAboveChart)
       
           .ChartTitle.Text = "Yieldauswertung"
           .Location Where:=xlLocationAsObject, Name:=ShName
     
       
   End With
   
   With ActiveChart.Parent
     .Left = 400
     .Top = 50
     .Width = 400
     .Height = 300
   End With
   
   'Arbeitsblatt umbenennen
   ThisWorkbook.Worksheets(1).Name = "Yieldauswertung"

End Sub