25.07.2016, 13:15
Hallo,
ich habe einen VBA-Excel-Script erstellt bei dem txt-Files eingelesen
werden und automatisch Diagramme auf Tabellenblättern erzeugt werden.
Bei den ersten zwei Blättern ist auch alles ok.
Nur beim dritten Tabellenblatt steht anstelle vom x-Wert nur eine 1 oder 2.
Kann mir jemand einen Tipp geben ?
Danke und Gruß im voraus
Günti
ich habe einen VBA-Excel-Script erstellt bei dem txt-Files eingelesen
werden und automatisch Diagramme auf Tabellenblättern erzeugt werden.
Bei den ersten zwei Blättern ist auch alles ok.
Nur beim dritten Tabellenblatt steht anstelle vom x-Wert nur eine 1 oder 2.
Kann mir jemand einen Tipp geben ?
Code:
Sub Import_mit_Dialog()
Dim Quelle As Object, Ziel As Object
Dim Datei_1 As String
Dim Datei_2 As String
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
Datei = Application.GetOpenFilename("Excel-Dateien(*.yld),*xls")
'Abbrechen falls keine Datei ausgewählt
If Datei = "Falsch" Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
'Ausgewählte Datei öffnen
Workbooks.Open Filename:=Datei
'Datei einlesen und Variable mit Dateinamen beschreiben
Set Quelle = ActiveWorkbook.Worksheets(1)
Datei_1 = ActiveWorkbook.Worksheets(1).Name
'Tabellenblatt beschreiben und umbenennen
Set Ziel = ThisWorkbook.Worksheets(1)
ThisWorkbook.Worksheets(1).Name = Datei_1
'kopieren und einfügen
Quelle.UsedRange.Copy Ziel.Cells(1, 1)
ActiveWorkbook.Close
'Yield_Auswertung
Rows(r + 1).Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Prüfauftrag"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Yield in Prozent"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Gutprüfung"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Schlechtprüfung"
Dim LastRow As Long
Dim Rng1 As Range
Dim ShName As String
'Zelle mit Gutstückzähler = 0 löschen
Dim i
For i = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 2).Value = "0" Then
Rows(i).Delete
End If
Next
'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
'Zahlenformat festlegen
Range("G1:G30").NumberFormat = "#,##0.00"
'Mittelwertberechnung
ActiveSheet.Range("F2").Value = "Gesamtyield = "
ActiveSheet.Range("G2").Value = WorksheetFunction.Average(ActiveSheet.Columns(2))
ActiveSheet.Range("H2").Value = "%"
'Anpassung der Spaltenbreite
Call ActiveSheet.Columns.AutoFit
'Diagramm einfügen
Charts.Add
With ActiveChart
.ChartType = xlColumnClustered
.SetSourceData Source:=Rng1
'Beschriftung Diagramm
.HasTitle = True
.ChartTitle.Text = "Yield Endprüfung " & ShName
.Location Where:=xlLocationAsObject, Name:=ShName
End With
'Auf Tabelle2 (Blatt2) wechseln
Sheets("Tabelle2").Activate
'Dialog "Datei öffnen" anzeigen
Datei = Application.GetOpenFilename("Excel-Dateien(*.yld),*xls")
'Abbrechen falls keine Datei ausgewählt
If Datei = "Falsch" Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
'Ausgewählte Datei öffnen
Workbooks.Open Filename:=Datei
'Datei einlesen und Variable mit Dateinamen beschreiben
Set Quelle = ActiveWorkbook.Worksheets(1)
Datei_2 = ActiveWorkbook.Worksheets(1).Name
'Tabellenblatt beschreiben und umbenennen
Set Ziel = ThisWorkbook.Worksheets(2)
ThisWorkbook.Worksheets(2).Name = Datei_2
'kopieren und einfügen
Quelle.UsedRange.Copy Ziel.Cells(1, 1)
ActiveWorkbook.Close
'Yield_Auswertung
Rows(r + 1).Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Prüfauftrag"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Yield in Prozent"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Gutprüfung"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Schlechtprüfung"
'Zelle mit Gutstückzähler = 0 löschen
For i = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 2).Value = "0" Then
Rows(i).Delete
End If
Next
'Letzte Zelle suchen und Bereich festlegen
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set Rng1 = .Range("A2:B" & LastRow)
ShName = .Name
End With
'Zahlenformat festlegen
Range("G1:G30").NumberFormat = "#,##0.00"
'Mittelwertberechnung
ActiveSheet.Range("F2").Value = "Gesamtyield = "
ActiveSheet.Range("G2").Value = WorksheetFunction.Average(ActiveSheet.Columns(2))
ActiveSheet.Range("H2").Value = "%"
'Anpassung der Spaltenbreite
Call ActiveSheet.Columns.AutoFit
'Diagramm einfügen
Charts.Add
With ActiveChart
.ChartType = xlColumnClustered
.SetSourceData Source:=Rng1
'Beschriftung Diagramm
.HasTitle = True
.ChartTitle.Text = "Yield Endprüfung " & ShName
.Location Where:=xlLocationAsObject, Name:=ShName
End With
'Auf Tabelle3 (Blatt3) wechseln
Sheets("Tabelle3").Activate
Dim LastRow_Gesamt As Long
Dim Rng1_Gesamt As Range
Dim ShName_Gesamt As String
'Gesamtyield für ausgewählte Monate ausgeben
ActiveSheet.Range("A2").Value = "Gesamtyield = "
ActiveSheet.Range("D2").Value = "%"
ActiveSheet.Range("A3").Value = "Gesamtyield = "
ActiveSheet.Range("D3").Value = "%"
'Kopieren und Einfügen aus Tabelle1 und Tabelle2 in Tabelle3
Sheets(Datei_1).Range("G2").Copy
Range("C2").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Sheets(Datei_2).Range("G2").Copy
Range("C3").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'Tabellenblattname in Zellen aus den Variablen schreiben
ActiveSheet.Range("B2").Value = Datei_1
ActiveSheet.Range("B3").Value = Datei_2
'Blatt 3 umbenennen
ThisWorkbook.Worksheets(3).Name = "Gesamtyield"
'Anpassung der Spaltenbreite
Call ActiveSheet.Columns.AutoFit
'Letzte Zelle suchen und Bereich festlegen
With ActiveSheet
LastRow_Gesamt = .Range("B" & .Rows.Count).End(xlUp).Row
Set Rng1_Gesamt = .Range("B2:C" & LastRow)
ShName_Gesamt = .Name
End With
'Diagramm einfügen
Charts.Add
With ActiveChart
.ChartType = xlColumnClustered
.SetSourceData Source:=Rng1_Gesamt
'Beschriftung Diagramm
.HasTitle = True
.ChartTitle.Text = "Yield Endprüfung " & ShName_Gesamt
.Location Where:=xlLocationAsObject, Name:=ShName_Gesamt
End With
'Speicher freigeben
Set Quelle = Nothing
Set Ziel = Nothing
Exit Sub
Fehler:
Set Quelle = Nothing
Set Ziel = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Sub Import_mit_Dialog()
Dim Quelle As Object, Ziel As Object
Dim Datei_1 As String
Dim Datei_2 As String
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
Datei = Application.GetOpenFilename("Excel-Dateien(*.yld),*xls")
'Abbrechen falls keine Datei ausgewählt
If Datei = "Falsch" Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
'Ausgewählte Datei öffnen
Workbooks.Open Filename:=Datei
'Datei einlesen und Variable mit Dateinamen beschreiben
Set Quelle = ActiveWorkbook.Worksheets(1)
Datei_1 = ActiveWorkbook.Worksheets(1).Name
'Tabellenblatt beschreiben und umbenennen
Set Ziel = ThisWorkbook.Worksheets(1)
ThisWorkbook.Worksheets(1).Name = Datei_1
'kopieren und einfügen
Quelle.UsedRange.Copy Ziel.Cells(1, 1)
ActiveWorkbook.Close
'Yield_Auswertung
Rows(r + 1).Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Prüfauftrag"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Yield in Prozent"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Gutprüfung"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Schlechtprüfung"
Dim LastRow As Long
Dim Rng1 As Range
Dim ShName As String
'Zelle mit Gutstückzähler = 0 löschen
Dim i
For i = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 2).Value = "0" Then
Rows(i).Delete
End If
Next
'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
'Zahlenformat festlegen
Range("G1:G30").NumberFormat = "#,##0.00"
'Mittelwertberechnung
ActiveSheet.Range("F2").Value = "Gesamtyield = "
ActiveSheet.Range("G2").Value = WorksheetFunction.Average(ActiveSheet.Columns(2))
ActiveSheet.Range("H2").Value = "%"
'Anpassung der Spaltenbreite
Call ActiveSheet.Columns.AutoFit
'Diagramm einfügen
Charts.Add
With ActiveChart
.ChartType = xlColumnClustered
.SetSourceData Source:=Rng1
'Beschriftung Diagramm
.HasTitle = True
.ChartTitle.Text = "Yield Endprüfung " & ShName
.Location Where:=xlLocationAsObject, Name:=ShName
End With
'Auf Tabelle2 (Blatt2) wechseln
Sheets("Tabelle2").Activate
'Dialog "Datei öffnen" anzeigen
Datei = Application.GetOpenFilename("Excel-Dateien(*.yld),*xls")
'Abbrechen falls keine Datei ausgewählt
If Datei = "Falsch" Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
'Ausgewählte Datei öffnen
Workbooks.Open Filename:=Datei
'Datei einlesen und Variable mit Dateinamen beschreiben
Set Quelle = ActiveWorkbook.Worksheets(1)
Datei_2 = ActiveWorkbook.Worksheets(1).Name
'Tabellenblatt beschreiben und umbenennen
Set Ziel = ThisWorkbook.Worksheets(2)
ThisWorkbook.Worksheets(2).Name = Datei_2
'kopieren und einfügen
Quelle.UsedRange.Copy Ziel.Cells(1, 1)
ActiveWorkbook.Close
'Yield_Auswertung
Rows(r + 1).Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Prüfauftrag"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Yield in Prozent"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Gutprüfung"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Schlechtprüfung"
'Zelle mit Gutstückzähler = 0 löschen
For i = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 2).Value = "0" Then
Rows(i).Delete
End If
Next
'Letzte Zelle suchen und Bereich festlegen
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set Rng1 = .Range("A2:B" & LastRow)
ShName = .Name
End With
'Zahlenformat festlegen
Range("G1:G30").NumberFormat = "#,##0.00"
'Mittelwertberechnung
ActiveSheet.Range("F2").Value = "Gesamtyield = "
ActiveSheet.Range("G2").Value = WorksheetFunction.Average(ActiveSheet.Columns(2))
ActiveSheet.Range("H2").Value = "%"
'Anpassung der Spaltenbreite
Call ActiveSheet.Columns.AutoFit
'Diagramm einfügen
Charts.Add
With ActiveChart
.ChartType = xlColumnClustered
.SetSourceData Source:=Rng1
'Beschriftung Diagramm
.HasTitle = True
.ChartTitle.Text = "Yield Endprüfung " & ShName
.Location Where:=xlLocationAsObject, Name:=ShName
End With
'Auf Tabelle3 (Blatt3) wechseln
Sheets("Tabelle3").Activate
Dim LastRow_Gesamt As Long
Dim Rng1_Gesamt As Range
Dim ShName_Gesamt As String
'Gesamtyield für ausgewählte Monate ausgeben
ActiveSheet.Range("A2").Value = "Gesamtyield = "
ActiveSheet.Range("D2").Value = "%"
ActiveSheet.Range("A3").Value = "Gesamtyield = "
ActiveSheet.Range("D3").Value = "%"
'Kopieren und Einfügen aus Tabelle1 und Tabelle2 in Tabelle3
Sheets(Datei_1).Range("G2").Copy
Range("C2").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Sheets(Datei_2).Range("G2").Copy
Range("C3").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'Tabellenblattname in Zellen aus den Variablen schreiben
ActiveSheet.Range("B2").Value = Datei_1
ActiveSheet.Range("B3").Value = Datei_2
'Blatt 3 umbenennen
ThisWorkbook.Worksheets(3).Name = "Gesamtyield"
'Anpassung der Spaltenbreite
Call ActiveSheet.Columns.AutoFit
'Letzte Zelle suchen und Bereich festlegen
With ActiveSheet
LastRow_Gesamt = .Range("B" & .Rows.Count).End(xlUp).Row
Set Rng1_Gesamt = .Range("B2:C" & LastRow)
ShName_Gesamt = .Name
End With
'Diagramm einfügen
Charts.Add
With ActiveChart
.ChartType = xlColumnClustered
.SetSourceData Source:=Rng1_Gesamt
'Beschriftung Diagramm
.HasTitle = True
.ChartTitle.Text = "Yield Endprüfung " & ShName_Gesamt
.Location Where:=xlLocationAsObject, Name:=ShName_Gesamt
End With
'Speicher freigeben
Set Quelle = Nothing
Set Ziel = Nothing
Exit Sub
Fehler:
Set Quelle = Nothing
Set Ziel = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Danke und Gruß im voraus
Günti