AW: Maximalwerte aus mehreren .txt Dateien Sammeln
25.01.2016 15:08:39
fcs
Hallo Fred,
hier ein Makro mit entsprechender Funktionalität.
Gruß
Franz
'Makro in einem allgemeinen Modul
Sub prcGet_Max_from_TXT()
Dim wksZiel As Worksheet
Dim Zeile_Z As Long, Zeile As Long
Dim varA, dblMax As Double
Dim wkbTxt As Workbook, wksTxt As Worksheet
Dim varOrdner As Variant, varDatei
Dim varData As Variant
Set wksZiel = ActiveSheet
With wksZiel
'letteZeile in Spalte A mit Inhalt
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Ordner auswählen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte den Ordner mit den Text-Dateien auswählen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
Application.ScreenUpdating = False
'txt-Dateien suchen
varDatei = Dir(varOrdner & "\*.txt")
Do Until varDatei = ""
'Textdatei öffnen - 1000er- und Dezimal-Trennzeichen anpassen, Local auf False _
setzen wenn Daten nicht mit den lokalen Einstellungen der Systemsteuerung übereinstimmen.
Application.Workbooks.OpenText Filename:=varOrdner & "\" & varDatei, Origin:=xlWindows, _
Startrow:=1, DataType:=xlDelimited, Tab:=False, Semicolon:=False, Comma:=False, _
Space:=True, Other:=False, ThousandsSeparator:=".", DecimalSeparator:=",", _
Local:=True
Set wkbTxt = ActiveWorkbook
Set wksTxt = wkbTxt.Sheets(1)
'Daten in SpaltenA und B in eine Daten-Array schreiben - Auswertung geht dann schneler.
With wksTxt
varData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
End With
'Werte für Spalte A und B zurücksetzen
varA = "no Data"
dblMax = -99999
If UBound(varData, 1) >= 428 Then
varA = varData(428, 1)
dblMax = varData(428, 2)
For Zeile = 428 To UBound(varData, 1)
If IsNumeric(varData(Zeile, 2)) Then
If varData(Zeile, 2) > dblMax Then
varA = varData(Zeile, 1)
dblMax = varData(Zeile, 2)
End If
End If
Next
End If
'text-Datei ohne speichern wieder schliesen
wkbTxt.Close savechanges:=False
'daten-Array löschen
Erase varData
'gefundenen Werte in Zieltabelle eintragen
With wksZiel
Zeile_Z = Zeile_Z + 1
.Cells(Zeile_Z, 1) = varA
.Cells(Zeile_Z, 2) = dblMax
.Cells(Zeile_Z, 3) = varDatei
End With
'nächste datei suchen
varDatei = Dir
Loop
Beenden:
Application.ScreenUpdating = True
End Sub
