AW: Werte über VBA auslesen - Zusatzfragen
20.10.2010 03:56:24
fcs
Hallo Burkhard,
hier das angepasste Makro zum Erzeugen der entsprechenden Formeln.
Gruß
Franz
Option Explicit
'Verzeichnis der Dateien
Private Const cstrPath As String = _
"C:\Dokumente und Einstellungen\Burkhard Held\Eigene Dateien\Werkzeugkosten"
'Private Const cstrPath As String = _
"C:\Users\Public\Test\Werkzeugkosten"
'Tabelle mit Daten
Private Const cstrSheet As String = "Kosten Gesamt"
Private Sub CommandButton1_Click()
Dim strFormula As String, strFile As String, strPath As String, lngMon As Long
Dim strFormel1 As String
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
strPath = IIf(Right(cstrPath, 1) = "\", cstrPath, cstrPath & "\")
With Sheets("Auswertung WKZkosten Jahr")
'Alte Werte im Ausgabebereich löschen
.Range(.Cells(10, 2), .Cells(13, 13)).ClearContents
For lngMon = 1 To 12
'Prüfen, ob Monatsdatei im Verzeichnis vorhanden, Suchstring "*_Mon_" und _
Zahlenformat der Monatszahl (wenn immer mit 2 Ziffern) ggf. anpassen
strFile = Dir(strPath & "*_Mon_" & Format(lngMon, "0") & ".xls*", vbNormal)
If strFile "" Then
'Formelteil mit Verzeichnis, Dateiname und Blattname
'Verdopplung der Hochkommata im Dateinamen in der Formel erforderlich!!
strFormel1 = "'" & strPath & "[" & Replace(strFile, "'", "''") & "]" & cstrSheet & "'!"
'Formeln für einzelne Zellen berechnen und in Blatt eintragen
strFormula = "=SUM(" & strFormel1 & "$C$3:$C$33)"
.Cells(10, lngMon + 1).Formula = strFormula
strFormula = "=SUM(" & strFormel1 & "$D$3:$D$33)"
.Cells(11, lngMon + 1).Formula = strFormula
strFormula = "=" & strFormel1 & "$E$34"
.Cells(12, lngMon + 1).Formula = strFormula
strFormula = "=" & strFormel1 & "$F$34"
.Cells(13, lngMon + 1).Formula = strFormula
End If
Next
.Calculate
'erstellte Formeln durch Werte Ersetzen
.Range(.Cells(10, 2), .Cells(13, 13)).Value = .Range(.Cells(10, 2), .Cells(13, 13)).Value
End With
ErrExit:
With Application
If Err.Number 0 Then
MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description
End If
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub