Makro:Daten aus Files und oder Blättern in CSV Export
Aus XIMES
Zielsetzung
Flexibel aus verschiedenen Dateien und/oder Blättern die Daten heraus ziehen, formatieren, zusammenspielen, neue Daten - so erforderlich - berechnen.
Makro
Option Explicit 'Dieser Zusatz muss IMMER dabei sein.
'HINTERGRUND bzw. Zielsetzung des Makros:
' In mehreren GEÖFFNETEN Dateien mit bestimmten Namen(steile) ***programmierbar***
' gehe auf Blätter mit bestimmten Namen(steile) ***programmierbar*** und
' hole dort aus definierten Spalten ***programmierbar*** Werte
'ERGIBT
' CSV-Datei mit Daten für Import in TIS
' Report.csv Datei ... wie viele Sätze wurden aus welchen Dateien/Blättern genommen
'DEBUGGING HINWEIS: Wenn die Fehlermeldung "File alread open" bei Debuggen kommt, dann
'runter gehen zu close #1 ... mit set Next Statement(rechte Maustaste)
'das aktivieren und F5 drücken. Dann ist alles wieder zu.
Sub GetDataFromExcelIntoCSV_File()
Dim ZeileAktuellinAusgabeDatei As Long '...Typ Long statt Integer erlaubt
'grosse zahlen (über 32500) und hier das Zusammenspielen von mehr als 65.000 Zeilen
Dim ZeileAktuellFürLesen As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ra As Range
Dim i, j As Long
Dim Überschrift As String
Dim ersterNameWB As String
ersterNameWB = ActiveWorkbook.Name
'***Anpassen des Namens der Output-Dateien***
Open ActiveWorkbook.Path & "\ResultFürTIS.csv" For Output As #1
'Ergebnisdatei ... Name anpassen
'über "#1" wird dann die Datei Nummer 1 angesprochen.
Open ActiveWorkbook.Path & "\ResultFürTIS_REPORT.csv" For Output As #2
'Kurzbericht zu Export (Felder und Zeilen) ... Name anpassen
ZeileAktuellinAusgabeDatei = 1
'WICHTIG
'Die Ergebnisdateien werden in das Verzeichnis am Computer gespeichert,
'in dem sich die gerade aktive Excel-Datei befindet.
'(aktiv = das was am Bildschirm als EXCEl sichtbar ist)
'Das kann verschieden sein von jenem EXCEL-Workbook, in dem das Makro steht.
'Das kann verschieden sein von jenem EXCEL-Workbook, in dem Daten stehen.
ZeileAktuellinAusgabeDatei = 0
'Für jedes Workbook
For Each wb In Workbooks
'*** Anpassen welche Workbooks betroffen sind***
'Suche nach jenen offenen Excel-Workbooks, deren Namen, dem Suchbegriff entsprechen kann
'... "?" ist Platzhalter für 1 Zeichen, "*" ist Platzhalter für beliebig viele.
'ZB If wb.Name Like "*06" Then ... nimmt alle offenen Excel-Workbooks, die mit 06 enden.
'Optionen bzw. Alternativen:
'If wb.Name = "A.xls" or wb.Name = "B.xls" or wb.Name = "C.xls" Then
'If wb.Name = ActiveWorkbook.name Then 'Wenn nur das aktive verwendet werden soll
'If wb.Name <> ActiveWorkbook.name Then 'Wenn nur das aktive NICHT verwendet werden soll
If wb.Name Like "*RTC*" Then
wb.Activate 'Bringt Datei nach vorne
'Für jedes Blatt
For Each ws In ActiveWorkbook.Worksheets
'***Anpassen welche Worksheets in der Workbooks betroffen sind***
'ähnlich wie oben
If ws.Name Like "??Report" Then
'Wählt die Zellen des Blattes aus
Set ra = ws.Cells
If ZeileAktuellinAusgabeDatei = 0 Then
'Aufbau der Überschrift, schrittweise, damit Reihenfolge leichter verändert werden kann
Überschrift = "Datum"
Überschrift = Überschrift & Chr(9) & "Von"
Überschrift = Überschrift & Chr(9) & "Bis"
Überschrift = Überschrift & Chr(9) & "Einheit"
Print #1, Überschrift 'Druck in Ergebnisdatei
Print #2, "Es werden Daten in folgendem Aufbau:" 'Druck in Reportdatei
Print #2, Überschrift 'Druck in Reportdatei
Print #2, ""
Print #2, "Aus folgenden Dateien und Blättern gedruckt"
ZeileAktuellinAusgabeDatei = ZeileAktuellinAusgabeDatei + 1
End If
'Für Report
Print #2, "*********Aus: Datei: " & wb.Name & " aus Blatt:" & ws.Name
ZeileAktuellFürLesen = 0
'*** Anpassen, wenn Zeilen bekannt oder kein Header
'*** ANPASSEN - Prüfen ob ab Zeile
'*** ALTERNATIV For j= 1 to 10000
For j = 2 To ra.Rows.Count
'Anpassen, welche Zeilen genommen werden sollen
'zB Zeilen mit leeren Wert in Spalte 3 werden nicht berücksichtigt
If ra(j, 3) <> "" Then
ZeileAktuellFürLesen = ZeileAktuellFürLesen + 1
ZeileAktuellinAusgabeDatei = ZeileAktuellinAusgabeDatei + 1
'Hauptergebnis
Print #1, GetValuesCSV(ra, j) 'Schreibt Werte aus Zeile j
Else
'Hier eintragen, wie mit Sonderfällen zu arbeiten ist
'ZB andere Werte berechnen, Standardwete eintragen ähnlich wie GetValueCSV
'Stop
End If
Next
Print #2, "Zeilen aus diesem Blatt gelesen: " & ZeileAktuellFürLesen; " Zeilen aus diesem Blatt geschrieben(exkl. Header): " & ZeileAktuellinAusgabeDatei - 1
End If
Next
End If
'wb.close 'Optional schliessen des Workbooks
Next
Close #1 'Schliessen der Ergebnisdatei
Close #2 'Schliessen der Reportdatei
Workbooks(ersterNameWB).Activate
End Sub
'***HILFSFUNKTION ... Anpassen: welche Spalten, mit welchem Format, etwaige (berechnete) Zusatzspalten, ... *** Function GetValuesCSV(ra As Range, Nr As Long) As String 'ra sind die Zellen des aktuellen Blattes 'Nr ist die Zeile 'über Spaltennummer der Range ra entscheidet sich, welche Spalten eingelesen werden bzw. 'auf welchen Spalten berechnet wird
GetValuesCSV = ra(Nr, 1)
'Baut String auf mit Char(9) = TAB als Trennzeichen, wenn lieber ";" ginge das auch
'TAB ist stabiler weil ein Text ja auch ; enthalten könnte
'Hier können auch Bereinigungen stattfinden: siehe zB MakeTime
'Beispiele:
'GetValuesCSV = GetValuesCSV & Chr(9) & "text" ... erzeugt Zusatzspalte mit text
'GetValuesCSV = GetValuesCSV & Mid(ActiveWorkbook.Name, 2, 4) ... erzeugt Zusatzspalte
'mit Namensteil des Workbooks (falls der zB für einen Bereich steht)
GetValuesCSV = GetValuesCSV & Chr(9) & ra(Nr, 2)
GetValuesCSV = GetValuesCSV & Chr(9) & Format(ra(Nr, 3), "HH:mm")
'formattiert zB in HH:mm (Achtung nicht hh:mm ... das ist 12h Notation
'Sonst wie in Hilfe zu Zellenformattierung
GetValuesCSV = GetValuesCSV & Chr(9) & ra(Nr, 4)
End Function
