AW: Auswertung von mehreren Dateien mit VBA
14.06.2015 18:13:16
mehreren
Hallo Mat,
freut mich, dass es klappt.
Hier der Code mit ein paar Kommentaren.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importCSV()
Dim objSh As Worksheet
Dim strFile As String, strPath As String
Dim vntRet As Variant, varValues() As Variant, varTmp(3) As Variant
Dim lngI As Long, lngLast As Long
Dim rng As Range
Dim lngCalc As Long
On Error GoTo ErrExit 'Fehlerbehandlung
'XL "ruhig" stellen
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
strPath = fncBrowseForFolder 'Verzeichnissauswahl oder alternativ
'strPath = "E:\Forum\Test2" 'Pfad fest vorgeben
If strPath <> "" Then
strPath = strPath & IIf(Right(strPath, 1) = "\", "", "\")
strFile = Dir(strPath, vbNormal) 'erste Datei im Verzeichnis suchen
Set objSh = ThisWorkbook.Worksheets.Add 'neue tenporäre Tabelle erstellen
Do While strFile <> "" 'so lange eine Datei gefunden wird
If strFile Like "*.csv" Then 'wenn es eine csv-datei ist
varTmp(0) = strFile 'Dateiname in temporärem Array speichern
With objSh
.Cells.Clear 'Zellen der Tabelle leeren
'Textdatei importieren
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=Range("$A$1"))
.Name = "temp"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = " "
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Application.StatusBar = "Analysiere Datei: " & strFile
lngLast = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Datenzeile des Importes
Set rng = .Columns(12).Find(What:="1", LookAt:=xlWhole, LookIn:=xlValues) 'die erste 1 suchen
If Not rng Is Nothing Then 'wenn "1" gefunden
varTmp(1) = .Cells(rng.Row, 5).Value 'Position im tem. Array speichern
vntRet = Application.Min(.Range(.Cells(2, 5), .Cells(lngLast, 5))) 'Minimum Position ermitteln
If IsNumeric(vntRet) Then
varTmp(2) = .Cells(rng.Row, 5).Value - vntRet 'Minimum im tem. Array speichern
End If
vntRet = Application.Max(.Range(.Cells(rng.Row, 11), .Cells(lngLast, 11))) 'Max. Kraft ab Zeile mit 1 ermitteln
If IsNumeric(vntRet) Then
varTmp(3) = vntRet * 10 ^ -10 'Max. im tem. Array speichern
End If
End If
End With
Redim Preserve varValues(lngI) 'Ausgabearray neu dimensionieren
varValues(lngI) = Array(varTmp(0), varTmp(1), varTmp(2), varTmp(3)) 'Werte an Array übergeben
lngI = lngI + 1
Erase varTmp
End If
strFile = Dir 'nächste Datei suchen
Loop
objSh.Delete
If lngI > 0 Then
With Sheets("Ausgabe")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 4)) = "" 'zellen in "Ausgabe" leeren
.Cells(2, 1).Resize(UBound(varValues, 1) + 1, 4) = Application.Transpose(Application.Transpose(varValues)) 'Daten aus Array in Tabelle schreiben
End With
End If
End If
'Fehlerbehandlung
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'importCSV'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - importCSV"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Gruß Sepp