Daten einlesen
08.04.2016 20:27:28
Burkhard
ich habe mit meinen sehr begrenzten VBA Kenntnissen leider mal wieder ein Problem!
meine bislang schon super gewordene Auswertung möchte ich noch einmal verbessern.
die Auswertung ist bislang dafür da, Produktionszahlen aus einer Wöchentlichen Datei zentral in eine Neue Exceldatei einzulesen.
Die Wöchentliche Datei wird an einem anderen Ort gespeichert und es wird jede Woche eine neue Datei erstellt, dessen Name mit der wochenzahl endet.
Der Bisherige Import der Daten läuft Super, das Makro, sowie die Exceldateien, als Muster hänge ich mit an.
Nun möchte ich noch folgendes:
In der wöchentlichen Datei, möchte ich unter den Produktionszahlen die Ausfallzeiten eingeben sheet "Schichteingabe" ab Zeile 31 die Daten sollen dann in die Tabelle "Ausfallzeiten_2016"
Hier sollten in den Spalten A-B vorher noch Jahr/KW/Datum dies könnte man auch oben aus den Zellen abgreifen wie im anderen Makro.
Über eure Unterstützung würde ich mich sehr freuen, ich selber habe mal wieder versucht anhand des vorhandenen Makros zu basteln, aber bisher sehr erfolglos.
Beispiel Datei:
https://www.herber.de/bbs/user/104854.xlsx
Das bisherige Makro:
Option Explicit
Private Const cstrPath = "C:\Users\bh92344\Desktop\Auswertung neu\"
Private Const cstrSheet As String = "Schichteingabe" 'Tabelle
Private Const cstrSheet2 As String = "Auslastung Fertigung" 'Tabelle
Private Const AnzMaschinen = 22 'Anzahl Maschinen in jedem KW-Blatt
' neu ******************
Public Jahr As String
Public Blattname As String
' neu ******************Ende******
Sub JahrInit()
Jahr = Sheets("einfache Auswertung über Jahr").Range("D1")
Blattname = "Tagesdaten_" & Jahr
End Sub
Sub AuswertungTage() 'mit direkter Übertragung der Zellwerte
Dim strFormula As String, strFile As String, strPath As String, lngKW As Long
Dim vVorgabe, Zeile As Long, Spalte As Long, Tag As Long, Zeile1 As Long, Maschine
Dim wbKW As Workbook, wksKW As Worksheet, wksKW2 As Worksheet
Dim wksTagesdaten As Worksheet, wksWochendaten As Worksheet
On Error GoTo ErrExit
' neu ******************
JahrInit
' neu ******************Ende******
' neu ****************** oder auch so ...sheets(Blattname)
Set wksTagesdaten = ActiveWorkbook.Worksheets("Tagesdaten_" & Jahr)
' neu ******************Ende******
'Set wksTagesdaten = ActiveWorkbook.Worksheets("" & Blattname & "")
Set wksWochendaten = ActiveWorkbook.Worksheets("Auswertung über Wochen")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'strPath = IIf(Right(cstrPath, 1) = "\", cstrPath, cstrPath & "\")
' neu ******************
strPath = cstrPath & Jahr & "\"
' neu ******************Ende******
With wksTagesdaten
'nächste leere Zeile in Liste in Spalte "KW"
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
If Zeile = 2 Then ' noch keine Daten in Tabelle
lngKW = 1
Else
lngKW = .Cells(Zeile - 1, 2).Value + 1 'nächste KW
vVorgabe = Application.InputBox(Prompt:="Ab welcher KW sollen Daten eingelesen werden?" _
& vbLf & "Bei Eingabe 1 werden alle Daten neu eingelesen" _
& vbLf & "Letzte eingelesene KW: " & lngKW - 1, _
Title:="Tagesdaten der KW einlesen", Default:=lngKW, Type:=1)
If vVorgabe = False Then GoTo Beenden
If vVorgabe "" Then
'KW-Datei öffnen
Set wbKW = Workbooks.Open(Filename:=strPath & strFile, ReadOnly:=True)
Set wksKW = wbKW.Worksheets(cstrSheet)
Set wksKW2 = wbKW.Worksheets(cstrSheet2)
'Daten der Tage der KW einlesen
With wksTagesdaten
Zeile1 = Zeile
For Tag = 1 To 6
Spalte = 8 + (Tag - 1) * 6 '1. Spalte des Tages (Anzahl Schichten)
'Werte für Jahr-KW-Datum für alle Maschinen
.Range(.Cells(Zeile, 1), .Cells(Zeile + AnzMaschinen - 1, 1)).Value = _
wksKW.Cells(1, 1) 'Jahr aus Zelle A1 (A2 ?) einlesen
.Range(.Cells(Zeile, 2), .Cells(Zeile + AnzMaschinen - 1, 2)).Value = _
wksKW.Cells(1, 2) 'KW aus Zelle B1 (C1 ?) einlesen
.Range(.Cells(Zeile, 3), .Cells(Zeile + AnzMaschinen - 1, 3)).Value = _
wksKW.Cells(5, Spalte) 'Tages-Datum aus Zeile 5
'Werte für Daten zu den einzelnen Maschinen eintragen
For Maschine = 1 To AnzMaschinen
Spalte = 8 + (Tag - 1) * 6 '1. Spalte des Tages (Anzahl Schichten)
.Cells(Zeile, 4).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, 1) 'Maschinen-Nr.
.Cells(Zeile, 5).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, 2) 'Maschine-Produkt
.Cells(Zeile, 6).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte) ' Stück Frühschicht
.Cells(Zeile, 7).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte + 1) 'Stück Spätschicht
.Cells(Zeile, 8).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte + 2) 'Stück Nachtschicht
.Cells(Zeile, 11).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte + 3) 'AnzRüst
.Cells(Zeile, 12).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte + 4) 'Rüstz
.Cells(Zeile, 9).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte + 5) 'Ist Stückzahl
'.Cells(Zeile, 10).Offset(Maschine - 1, 0).Value = _
wksKW.Cells(Maschine + 6, Spalte) 'Anzahl Schichten
'Anzahl Schichten einlesen
Spalte = 8 + (Tag - 1) * 4 '1. Spalte des Tages (Anzahl Schichten)
'Werte für Daten zu den einzelnen Maschinen eintragen
.Cells(Zeile, 10).Offset(Maschine - 1, 0).Value = _
wksKW2.Cells(Maschine + 6, Spalte) 'Anzahl Schichten
Next
'1. Zeile für nächsten Tag
Zeile = Zeile + AnzMaschinen
Next
End With
'Formeln/Werte in Wochenauswertung aktualisieren
With wksWochendaten
strFormula = "'[" & strFile & "]" & cstrSheet2 & "'!"
With .Range(.Cells(10, lngKW + 1), .Cells(32, lngKW + 1))
.Formula = "=SUMPRODUCT((" & strFormula _
& "$A$7:$A$29=$A10)*(MOD(COLUMN($H:$AE)-7,4)=0)*" & strFormula & "$H$7:$AE$29)"
.Calculate
.Value = .Value
End With
End With
'Datei mit KW_Daten wieder schliessen
wbKW.Close savechanges:=False
Set wbKW = Nothing
Set wksKW = Nothing
Set wksKW2 = Nothing
End If
Next lngKW
With wksTagesdaten
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row 'letzte Zeile mit Daten
End With
' ******************************** hier noch ändern *************************************
' überall, wo z.B. "=SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(MONTH(R1C)"
' steht, den String aufsplitten und die Variable Blattname mit reinpfriemeln, also etwa:
' "=SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(MONTH(R1C)"
' am besten mit Suchen und Ersetzen,
' Suchen nach: " & Blattname & "
' (ohne "")
' ersetzen mit: " & Blattname & "
' (mit "")
'Formeln/Werte in Monatsauswertung aktualisieren
With Worksheets("Auswertung über Monate")
With .Range("E2:P23")
.FormulaR1C1 = _
"=SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(MONTH(R1C)=MONTH(" & _
Blattname & "!R2C3:R" _
& Zeile & "C3))*" & Blattname & "!R2C9:R" & Zeile & "C9)"
.Calculate
.Value = .Value 'Zeile aktivieren, wenn im Zellbereich keine Formeln stehen sollen
End With
'Formeln/Werte in Monatsauswertung Schichten aktualisieren
With .Range("E30:P51")
.FormulaR1C1 = _
"=IF(SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(MONTH(R1C)=MONTH(" & _
Blattname & "!R2C3:R" _
& Zeile & "C3))*" & Blattname & "!R2C9:R" & Zeile & "C9)=0,0,SUMPRODUCT((RC1=" & _
Blattname & "!R2C4:R" & Zeile & "C4)*(MONTH(R1C)=MONTH(" & Blattname & "!R2C3:R" _
& Zeile & "C3))*" & Blattname & "!R2C9:R" & Zeile & "C9)/SUMPRODUCT((RC1=" & Blattname & _
"!R2C4:R" & Zeile & "C4)*(MONTH(R1C)=MONTH(" & Blattname & "!R2C3:R" _
& Zeile & "C3))*" & Blattname & "!R2C10:R" & Zeile & "C10))"
.Calculate
.Value = .Value 'Zeile aktivieren, wenn im Zellbereich keine Formeln stehen sollen
End With
End With
With wksTagesdaten
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row 'letzte Zeile mit Daten
End With
'Formeln/Werte in Wochenauswertung Schichten aktualisieren
With wksWochendaten 'Worksheets("Auswertung über Wochen_2012")
With .Range("B41:BA61")
.FormulaR1C1 = _
"=IF(SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(R39C=" & Blattname & "!R2C2: _
R" & Zeile & "C2)*(" & Blattname & "!R2C9:R" _
& Zeile & "C9))=0,0,SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(R39C=" & _
Blattname & "!R2C2:R" & Zeile & "C2)*(" & Blattname & "!R2C9:R" _
& Zeile & "C9))/SUMPRODUCT((RC1=" & Blattname & "!R2C4:R" & Zeile & "C4)*(R39C=" & _
Blattname & "!R2C2:R" & Zeile & "C2)*(" & Blattname & "!R2C10:R" & Zeile & "C10)))"
.Calculate
.Value = .Value 'Zeile aktivieren, wenn im Zellbereich keine Formeln stehen sollen
End With
End With
ErrExit:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
If Not wbKW Is Nothing Then wbKW.Close savechanges:=False
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Beenden:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub