Excel & VBA

Es wird geprüft, ob der Ordner existiert. Wenn nicht, wird er erstellt. Ggf. noch daran denken, etwaige Fehler abzufangen.

Dim strPfad As String strPfad = "\\COMPUTER\Ordner\Unterordner\" 'Beispiel für Netzwerk strPfad = "C:\Temp\" 'Beispiel lokal If Dir(strPfad, vbDirectory) <> "" Then MsgBox "Verzeichnis existiert bereits" Else MkDir strPfad End If

Mit Application.ScreenUpdating = False kann ausgeschaltet werden, dass der Excel-Bildschirm aktualisiert wird. Wenn oft automatisiert mit Zellen gearbeitet wird, kann das sinnvoll sein - einerseits flackert es dann nicht so, andererseits wird die Laufzeit teilweise erheblich verkürzt, wenn nicht sofort alle Änderungen angezeigt werden.

Allerdings sollte nicht vergessen werden, diese Aktualisierung wieder einzuschalten. Vergisst man dies, ist der Bildschirm eventuell an wichtiger Stelle „eingefroren“. Man kann das zwar einfach mit Application.ScreenUpdating = True beheben - wenn es jedoch einem anderen Anwender passiert, kann das mächtig irritieren.

Dim strDateiPfad As String strDateiPfad = "C:\eigene dateien\test.xlsx" Application.ScreenUpdating = False Workbooks.Open Filename:=strDateiPfad ThisWorkbook.Activate Application.ScreenUpdating = True

Sinnvoll kann es auch sein, vor der Ausführung des gewünschten Codes die Eigenschaft in einer Variablen zu speichern, wie z. B. bolScrUpd = Application.ScreenUpdating. Nach dem relevanten Code setzt man das dann auf den Ausgangszustand mit Application.ScreenUpdating = bolScrUpd zurück.

Damit wird die Datei einfach geöffnet, wenn sie existiert:

Workbooks.Open FileName:="C:\Eigene Dateien\Test.xlsx"

Sicherheitshalber sollte vorher geprüft werden, ob die Datei existiert, um Fehlermeldungen zu vermeiden:

Dim strPfad As String strPfad = "C:\Temp\Test.xlsx" If Dir(strPfad) = "" Then MsgBox "Die Datei " & vbNewLine & strPfad & vbNewLine & "existiert nicht.", vbOKOnly + vbCritical, "Fehler" Else Workbooks.Open Filename:=strPfad End If

Ggf. sollte noch geprüft werden, ob eine Datei mit dem Namen bereits offen ist. Dazu kann man den Fehler abfangen oder vorher mit For Each objMappe in Workbooks prüfen, ob objMappe.name wie der Name der aufzurufenden Datei ist.

Dateiname in Zelle

Wenn der Dateiname in einer Zelle (hier A1) steht, kann so vorgegangen werden:

Sub Aufruf() Workbooks.Open FileName:=Range("A1") End Sub

Dabei darf natürlich nicht der Ordnerpfad vergessen werden, in dem sich diese Datei befindet. Der kann komplett mit in A1 stehen oder noch vorangestellt werden.

Auch hier sollte vorher noch mit Dir() geprüft werden, ob die Datei überhaupt existiert.

In einer Zelle

Die Nummer in eine Zelle schreiben, die auch ausgeblendet werden kann. Dann bei jedem Speichern die Nummer mit z. B. Range("A1") = Range("A1") + 1 erhöhen.

In den Dokumenteigenschaften

Die CustomDocumentProperties der Datei können auch mit VBA-Code verwendet werden. Dann wird die Nummer versteckt in dieser Datei gespeichert:

Dazu einmalig die Eigenschaft mit der folgenden Zeile erstellen:

ThisWorkbook.CustomDocumentProperties.Add Name:="lfdNr", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=0

Anzeigen kann man den Wert, der neu 0 ist, mit der Zeile:

MsgBox ThisWorkbook.CustomDocumentProperties("lfdNr").Value

Erhöht wird der der Wert mit

ThisWorkbook.CustomDocumentProperties("lfdNr").Value = ThisWorkbook.CustomDocumentProperties("lfdNr").Value + 1

Nach dem Erhöhen des Wertes nicht vergessen, die Datei zu speichern. Auch wenn diese Eigenschaften nicht sichtbar sind, sind sie doch in der Datei enthalten.

Separate Textdatei

Oder die Nummer in eine Datei auslagern, zum Beispiel so:

Sub lfdNr() Dim lngDNr As Long, intNr As Integer Dim strDName As String, strZielordner As String, strDateiname As String strZielordner = ThisWorkbook.Path & "\" 'Hier den Pfad verändern strDateiname = "Excel_lfdNr" 'Hier den Dateinamen verändern strDName = strZielordner & strDateiname & ".ini" intNr = 0 lngDNr = FreeFile If Dir(strDName) <> "" Then Open strDName For Input As #lngDNr Input #lngDNr, intNr Close #lngDNr End If intNr = intNr + 1 lngDNr = FreeFile Open strDName For Output As #lngDNr Print #lngDNr, intNr; Close #lngDNr ActiveCell.Value = intNr End Sub

Der Code nimmt sich die erste Exceldatei, die im Ordner in der Variablen ist. Die ruft er auf, druckt deren erstes Blatt und schließt sie wieder. Mit Dir() wird nun die nächste Datei genommen und die gleiche Prozedur erneut ausgeführt - so lange, bis mit Dir() keine weitere Datei gefunden wird.

Sub AlleDrucken() Dim WB As Workbook Dim strFName As String strFName = Dir("C:\Excel\*.xls") While strFName <> "" Set WB = Workbooks.Open(Filename:=strFName) WB.PrintOut WB.Close strFName = Dir() Wend End Sub

Der Code funktioniert zwar, wie er hier angegeben ist. Allerdings ist die Gefahr eines Fehlers groß, wenn bereits Dateien geöffnet sind. Zumindest die Prüfung darauf sollte noch mit eingebaut werden.

Im Zusammenhang damit muss auch beachtet werden, ob eine offene Datei gespeichert ist. Wenn nicht, kommt es beim Schließen zur entsprechenden „Speichern?“-Frage durch Excel und der Code wird angehalten.

Im folgenden Beispiel muss natürlich noch der Ordner/Pfad beachtet und ggf. dem Dateinamen vorangestellt werden. Der kann in einer Zelle stehen oder im Code ergänzt werden.

Sub DatumEingeben() Dim varDatum varDatum = InputBox("Bitte Datum eingeben:") If Not IsDate(varDatum) Then MsgBox "Kein Datum!" Else varDatum = Format(varDatum, "yyyymmdd") & ".xls" End If Workbooks.Open varDatum End Sub

Der Code listet auf dem aktiven Tabellenblatt alle Dateien auf, deren Datumsangaben nach dem Datum liegen, das in eine InputBox eingegeben wurde.

Alle Dateien auflisten:

Sub DateiListe() Dim strOrdner As String, strFName As String, intI As Integer, varDatum Application.ScreenUpdating = False varDatum = InputBox("Ab wann?") If Not IsDate(varDatum) Then Exit Sub On Error GoTo ErrorHandler varDatum = CDate(varDatum) strOrdner = "C:\Ordnerpfad\" strFName = Dir(strOrdner & "*.xlsm") 'Ordner anpassen! intI = 0 Do While strFName <> "" If FileDateTime(strOrdner & strFName) > varDatum Then intI = intI + 1 Worksheets(1).Cells(intI, 1) = strFName Worksheets(1).Cells(intI, 2) = Format(FileDateTime(strOrdner & strFName), "DD.MM.YY") End If strFName = Dir() Loop ErrorHandler: Application.ScreenUpdating = True End Sub

Der Ordner muss natürlich noch angepasst werden und ggf. ist eine Prüfung, ob tatsächlich ein gültiges Datum eingegeben wurde, sinnvoll.

Vorsicht auch, falls sich auf dem Tabellenblatt bereits Daten befinden - die werden gnadenlos überschrieben. Möglich ist, für die Liste ein neues Tabellenblatt erstellen zu lassen.

Der Code leert zunächst die Listbox. Anschließend zeigt er den Dialog zur Dateiwahl, in dem die gewünschte Datei gewählt werden kann. Der Dialog wird so lange gezeigt, bis Abbrechen gewählt wird.

Bei der Listbox handelt es sich um ein ActiveX-Steuerelement

Sub DateienSammeln() Dim varPfad ActiveSheet.ListBox1.Clear varPfad = "" Do While varPfad <> False varPfad = Application.GetOpenFilename("Excel-Dateien (*.xl*), *.xl*") If varPfad <> False Then ActiveSheet.ListBox1.AddItem varPfad Loop End Sub

Natürlich kann man den gesamten Pfad am Backslash splitten oder andere Stringoperationen anwenden. Am einfachsten ist es aber sicher, wenn man sich mit Dir() den Dateinamen zurückgeben lässt - das geht auch mit allen Dateien, nicht nur mit Exceldateien.

Dir()

Rein für den Dateinamen wäre dies eine einfache Möglichkeit:

Sub DateinamenExtrahieren() Dim varDName varDName = Application.GetOpenFilename If varDName = False Then MsgBox "Nichts gewählt." Else varDName = Dir(varDName) MsgBox varDName End If End Sub

Für alle Angaben aus dem Pfad, also Ordner und Datei, könnte folgende Variante genutzt werden:

Sub DateiPfad() Dim strGesamt As String, strDatei As String, strOrdner As String strGesamt = Application.GetOpenFilename strDatei = Dir(strGesamt) strOrdner = Left(strGesamt, Len(strGesamt) - Len(Dir(strGesamt))) MsgBox strDatei & vbNewLine & strOrdner & vbNewLine & strGesamt End Sub

Wenn davon ausgegangen werden kann, dass die Zeichenfolge des Dateinamens einmalig im Pfad ist, kann auch einfach ersetzt werden:

Sub DateiAusPfad2() Dim varPfad, strOrdner As String, strDatei As String varPfad = Application.GetOpenFilename If varPfad <> False Then strDatei = Dir(varPfad) strOrdner = Replace(varPfad, strDatei, "") MsgBox strDatei & vbNewLine & strOrdner End If End Sub

Regulärer Ausdruck

Noch eine Variante für die Freunde regulärer Ausdrücke:

Sub DateiAusPfad3() Dim varDName, Regex As Object, regMatches, regMatch varDName = Application.GetOpenFilename If varDName = False Then MsgBox "Nichts gewählt." Else If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.+[\\\/])(.*)$" Set regMatches = Regex.Execute(varDName) MsgBox regMatches(0).SubMatches(1) Set Regex = Nothing End If End Sub

Der Schrägstrich wurde aufgenommen, weil Pfade in Onedrive gespeicherter Dateien mit Schrägstrich geliefert werden.

Sollen Ordner und Dateiname zurückgegeben werden, wäre dies möglich:

Sub DateiAusPfad4() Dim varPfad, strOrdner As String, strDatei As String Dim Regex As Object, regMatches, regMatch varPfad = Application.GetOpenFilename If varPfad <> False Then If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.+[\\\/])(.*)$" Set regMatches = Regex.Execute(varPfad) strOrdner = regMatches(0).SubMatches(0) strDatei = regMatches(0).SubMatches(1) Set Regex = Nothing MsgBox strDatei & vbNewLine & vbNewLine & strOrdner End If End Sub

Die integrierte Funktion =ZELLE("Dateiname";A1) liefert den kompletten Pfad bis zum Tabellenblatt. Der Dateiname ist dabei in eckige Klammern eingeschlossen: Pfad[Dateiname]Blattname. Mit einem regulären Ausdruck können die einzelnen Bestandteile ausgegeben werden (ggf. noch Fehlerbehandlung einbauen):

Sub DateiAusZellFunktion() Dim strPfad, strOrdner As String, strDatei As String, strBlatt As String Dim Regex As Object, regMatches, regMatch strPfad = Evaluate("=cell(""filename"",A1)") If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.*)\[(.*)\](.*)$" Set regMatches = Regex.Execute(strPfad) strOrdner = regMatches(0).SubMatches(0) strDatei = regMatches(0).SubMatches(1) strBlatt = regMatches(0).SubMatches(2) Set Regex = Nothing MsgBox strBlatt & vbNewLine & strDatei & vbNewLine & strOrdner End Sub

Dynamische Matrixformel (Arrayformel) und verschütteter Array

Per benutzerdefinierter Funktion können seit Excel 365 auch die einzelnen Ordner bzw. Bestandteile eines Pfades in Zellen ausgegeben werden. Dazu diese Funktion als Beispiel:

Function PfadDetails(ByVal strPfad As String) PfadDetails = "" If strPfad <> "" Then Select Case True Case InStr(1, strPfad, "\") > 0: PfadDetails = Split(Replace(strPfad, "\\", "\"), "\") Case InStr(1, strPfad, "/") > 0: PfadDetails = Split(Replace(strPfad, "//", "/"), "/") End Select End If End Function

In die Zelle kommt dann diese Formel:

=PfadDetails(A5)

Wenn wie hier im Beispiel in A5 ein Pfad steht, werden an der Zelle mit der Formel die einzelnen Elemente des Pfades ausgegeben. Das letzte Element sollte bei einem kompletten Pfad zu einer Datei der Dateiname sein.

Das Beispiel mit der Funktion =ZELLE("Dateiname";A1) kann auch als Arrayformel verwendet werden:

Function DateiAusZellFunktion(strFktPfad) Dim arrTemp(1 To 3) Dim Regex As Object, regMatches, regMatch DateiAusZellFunktion = "" If strFktPfad <> "" Then If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.*)\[(.*)\](.*)$" Set regMatches = Regex.Execute(strFktPfad) If regMatches.Count = 1 Then arrTemp(1) = regMatches(0).SubMatches(2) arrTemp(2) = regMatches(0).SubMatches(1) arrTemp(3) = regMatches(0).SubMatches(0) DateiAusZellFunktion = arrTemp End If Set Regex = Nothing End If End Function

In die Zelle kommt dann =DateiAusZellFunktion(ZELLE("Dateiname";A1)) und in ihr sowie den Nachbarzellen werden Blattname, Dateiname und Ordnerpfad erscheinen.

Formeln/integrierte Funktionen

Den aktuellen Ordner gibt diese Funktion zurück:

=INFO("Verzeichnis")

In anderen Sprachen geht übrigens auch einfach Basename(Pfad).

Eine einfache Möglichkeit:

Sub BlattSpeichern() Dim strTBName As String, strWBName As String strTBName = InputBox("Blattname:") If strTBName = "" Then Exit Sub strWBName = InputBox("Dateiname:") If strWBName = "" Then Exit Sub Worksheets(strTBName).Copy ActiveWorkbook.SaveAs strWBName ActiveWorkbook.Close End Sub

Allerdings ist es natürlich einfacher, wenn man den Blattnamen nicht tippen muss. Die Namen der Tabellen können zur Auswahl auch in eine beliebige Liste eingetragen werden.

Eine andere Möglichkeit wäre, statt Worksheets(strTBName) das aktive Blatt zu verwenden, also ActiveSheet, wenn dies möglich ist.

Für alle Fälle sollte jedoch noch eine Fehlerbehandlung eingebaut werden, falls das Blatt mit dem eingegebenen Namen nicht existiert oder falls eine Datei mit dem eingegebenen Namen im aktiven Ordner (in den hier gespeichert wird) bereits vorhanden ist.

Damit das Speichern flexibler, komfortabler und vor allem sicherer wird, kann auch ein Dialog eingesetzt werden, zum Beispiel Application.GetSaveAsFilename. Hier wäre dann auch gleich der komplette Pfad enthalten.

Eine Lösung, die noch aus den alten Diskettenlaufwerk stammt - aus Nostalgiegründen ist sie noch hier:

Sub LaufwerkAuswahl() Dim intI As Integer Dim strLWs As String, strLW As String, strStart As String strStart = Left(CurDir, 1) On Error Resume Next For intI = 97 To 122 'Laufwerke für den Inputbox-Text zusammenstellen Err.Clear ChDrive Chr(intI) If Err = 0 Then strLWs = strLWs & Chr(intI) & "," Next intI strLWs = Left(strLWs, Len(strLWs) - 1) strLW = InputBox("Bitte Laufwerk wählen (" & strLWs & "):", Right(strLW, 1)) If strLW = "" Then ChDrive strStart Else ChDrive strLW End If MsgBox CurDir End Sub

Kopiere von alt nach neu:

Dim strActive_Old As String, strFileToSave As String strActive_Old = "C:\Eigene Dateien\Test.xlsx" strFileToSave = "F:\Test1.xlsx" FileCopy strActive_Old, strFileToSave

Der Umweg über die Variablen muss natürlich nicht gegangen werden, die Pfade können auch direkt verwendet werden.

An der Stelle des Sternchens in Dir(strOrdner & "*.*") können auch bestimmte Dateiendungen eingetragen wreden, so dass nur nach Dateien eines Typs gesucht wird.

Subs

Sollen Dateien nur direkt im Ordner, nicht aber in Unterordnern, gesucht werden, reicht dieser Code:

Sub Suchen_nur_Dateien() Dim strOrdner As String, strDatei As String Dim lngZ As LongPtr strOrdner = "C:\Eigene Dateien\" lngZ = 2 Range("a1:e50000").ClearContents strDatei = Dir(strOrdner & "*.*") Do While strDatei <> "" If strDatei <> "" Then lngZ = lngZ + 1 Cells(lngZ, 1) = strOrdner & strDatei 'Pfad Cells(lngZ, 2) = FileLen(strOrdner & strDatei) 'Größe Cells(lngZ, 3) = FileDateTime(strOrdner & strDatei) 'Datum/Zeit Cells(lngZ, 4) = strDatei 'nur Dateiname End If strDatei = Dir Loop End Sub

Soll auch in Unterordnern gesucht werden, ist dies eine Möglichkeit:

Private lngZ As LongPtr Sub Suchen_mit_Unterordnern() 'Aufruf lngZ = 2 Range("a1:e50000").ClearContents Dateisuche "C:\Eigene Dateien", "*.*" End Sub Sub Dateisuche(strOrdner As String, strDateien As String) Dim strTemp As String, strWdhlg As String strOrdner = strOrdner & IIf(Right(strOrdner, 1) <> "\", "\", "") strTemp = Dir(strOrdner & strDateien) Do While Len(strTemp) Cells(lngZ, 1) = strOrdner & strTemp 'Pfad Cells(lngZ, 2) = FileLen(strOrdner & strTemp) 'Größe Cells(lngZ, 3) = FileDateTime(strOrdner & strTemp) 'Datum/Zeit Cells(lngZ, 4) = strTemp 'nur Dateiname lngZ = lngZ + 1 strTemp = Dir() Loop strTemp = Dir(strOrdner, vbDirectory) Do While Len(strTemp) If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strOrdner & strTemp) And vbDirectory) = vbDirectory Then Dateisuche strOrdner & strTemp, strDateien lngZ = lngZ - 1 strWdhlg = Dir(strOrdner, vbDirectory) lngZ = lngZ + 1 Do While strWdhlg <> strTemp: strWdhlg = Dir(): Loop End If End If strTemp = Dir() Loop On Error GoTo 0 End Sub

Matrixfunktion für dynamische Arrayformel

Wenn es nicht zu viele Dateien sind, können die auch mit einer Formel, die in einer Zelle steht, ausgegeben werden (ab Excel 365). Dazu dient folgende benutzerdefinierte Funktion (UDF):

Function Suchen_nur_Dateien(strOrdner) Dim strDatei As String, arrTemp() Dim lngArr As LongPtr lngArr = 0 strDatei = Dir(strOrdner & "*.*") Do While strDatei <> "" If strDatei <> "" Then lngArr = lngArr + 1 ReDim Preserve arrTemp(1 To 4, 1 To lngArr) arrTemp(1, lngArr) = strOrdner & strDatei 'Pfad arrTemp(2, lngArr) = FileLen(strOrdner & strDatei) 'Größe arrTemp(3, lngArr) = FileDateTime(strOrdner & strDatei) 'Datum/Zeit arrTemp(4, lngArr) = strDatei 'nur Dateiname End If strDatei = Dir Loop Suchen_nur_Dateien = arrTemp End Function

Wenn in A1 der Ordner (z. B. C:\Eigene Dateien\) steht, kann in eine andere Zelle folgende Formel eingetragen werden:

=MTRANS(Suchen_nur_Dateien(A1))

Damit werden die gefundenen Dateien ab der Zelle mit der Formel gefloatet eingetragen (verschüttet). Auch die Suche mit den Unterordnern lässt sich in dieser Form gestalten - aber Vorsicht, damit die Formel nicht ewig zum Berechnen braucht.

In Spalte A wird solange gesucht, bis eine leere Zelle gefunden wird. Natürlich wäre auch eine For-Schleife mit Application.Cells(Rows.Count, 1).End(xlUp).Row möglich.

Die Daten aus A, B und C werden mit einem Semikolon als Trennzeichen in eine Textdatei eingelesen.

Einlesen in eine Textdatei mit immer gleichem Pfad:

Sub AlsTextSpeichern() Dim intI As Integer, lngDNr As LongPtr lngDNr = FreeFile 'Pfad anpassen Open "C:\Eigene Dateien\aus Tabelle.txt" For Output As #lngDNr intI = 2 'erste Zeile mit Angaben Do While Cells(intI, 1).Value <> "" 'Schleife, solange die Zelle nicht leer ist 'Ãœbernehmen der Daten in die Textdatei Print #lngDNr, Cells(intI, 1) & ";" & Cells(intI, 2) & ";" & Cells(intI, 3) intI = intI + 1 Loop Close #lngDNr End Sub

Einlesen in eine Textdatei mit wählbarem Pfad:

Sub AlsTextSpeichern1() Dim intI As Integer, lngDNr As LongPtr Dim varPfad varPfad = Application.GetSaveAsFilename(InitialFileName:="Test", fileFilter:="Textdateien (*.txt), *.txt") If varPfad = False Then Exit Sub lngDNr = FreeFile Open varPfad For Output As #lngDNr intI = 2 Do While Cells(intI, 1).Value <> "" Print #lngDNr, Cells(intI, 1) & ";" & Cells(intI, 2) & ";" & Cells(intI, 3) intI = intI + 1 Loop Close #lngDNr End Sub

Textdatei in Exceldatei einlesen, immer gleicher Pfad:

Da das Semikolon als Trennzeichen verwendet wurde, brauchen wir die Textdatei als solche nicht aus- und in Excel einzulesen, sondern wir können die Datei direkt öffnen:

Sub AusTextAufrufen() On Error Resume Next 'falls Datei nicht existiert 'hier nur den Pfad ändern Workbooks.OpenText Filename:="C:\Eigene Dateien\aus Tabelle.txt", DataType:=xlDelimited, semicolon:=True End Sub

Textdatei in Exceldatei einlesen, wählbarer Pfad:

Sub AusTextAufrufen1() Dim varPfad varPfad = Application.GetOpenFilename(fileFilter:="Textdateien (*.txt), *.txt") If varPfad = False Then Exit Sub Workbooks.OpenText Filename:=varPfad, DataType:=xlDelimited, semicolon:=True End Sub

Gibt es andere Trennzeichen, erfolgt das Aufteilen auf die Zellen natürlich nicht unbedingt. Dann kann entweder mit Split() gearbeitet werden oder es kann mit der integrierten Methode Text in Spalten aufgeteilt werden.

Dynamische Arrayformel mit Matrixfunktion

Möglich ist natürlich auch ab Excel 365, die Textdatei mittels benutzerdefinierter Matrixfunktion auszulesen und die Ergebnisse als Array zu übergeben:

Function DateiEinlesen(strDatei, strTrenner, intSpalten) Dim intS As Integer, lngZ As LongPtr Dim lngDNr As Long, strZeile As String, arrTemp Dim arrS() lngDNr = FreeFile lngZ = 0 Open strDatei For Input As #lngDNr Do While Not EOF(lngDNr) Line Input #lngDNr, strZeile If strZeile <> "" Then arrTemp = Split(strZeile, strTrenner) lngZ = lngZ + 1 ReDim Preserve arrS(1 To intSpalten, 1 To lngZ) For intS = 1 To intSpalten If UBound(arrTemp) >= intS Then arrS(intS, lngZ) = arrTemp(intS) Else arrS(intS, lngZ) = "" End If Next End If Loop Close #lngDNr DateiEinlesen = Application.WorksheetFunction.Transpose(arrS) End Function

In die Zelle kommt dann nur noch die Formel:

=DateiEinlesen(Pfad zur Datei;Trennzeichen;Anzahl der Spalten)

=DateiEinlesen(A1;";";4)

Allerdings sollten die Dateien natürlich nicht zu groß sein, weil die Berechnung dieser Formel sonst alles verzögern würde.

Eine Möglichkeit ist, diese direkt in den Editor einzufügen - allerdings per Tastensimulation. Das geht sicher schnell, allerdings ist danach immer die Num-Taste ausgeschaltet:

Sub InTextExportieren() Dim intI As Integer Shell "Notepad.exe", 3 Application.SendKeys "Sicher ist die Num-Taste jetzt ausgeschaltet.~" For intI = 1 To 10 Application.SendKeys Sheets(intI).Range("A1").Value & "~" Next End Sub

Die bessere Alternative ist, die Werte in eine Textdatei zu speichern und anschließend diese Textdatei mit Notepad aufzurufen:

Sub InTextExportieren1() Dim intI As Integer, strPfad As String, lngDNr As LongPtr strPfad = ThisWorkbook.Path & "\temp.txt" lngDNr = FreeFile Open strPfad For Output As #lngDNr For intI = 1 To 10 Print #lngDNr, Sheets(intI).Range("A1").Value Next Close #lngDNr Shell "Notepad.exe " & strPfad, 3 End Sub

Vorsicht: Die Laufzeit dieser Schleifen kann sehr lang sein. Es ist deshalb mehr als ratsam, die zu durchsuchenden Ordner so stark wie möglich einzugrenzen.

Erste Möglichkeit:

Dim strPfad As String, bolWeiter As Boolean 'Aufruf Sub Suchen() strPfad = "": bolWeiter = True: Dateisuche "C:\", "test.txt" Range("A1") = strPfad End Sub Function Dateisuche(strLaufwerk, strDatei) Dim strTemp As String, strWdhlg As String On Error Resume Next strLaufwerk = strLaufwerk & IIf(Right(strLaufwerk, 1) <> "\", "\", "") strTemp = Dir(strLaufwerk & strDatei) Do While Len(strTemp) strPfad = strLaufwerk & strTemp If UCase(strTemp) = UCase(strDatei) Then Dateisuche = strPfad bolWeiter = False: Exit Function End If strTemp = Dir() Loop strTemp = Dir(strLaufwerk, vbDirectory) Do While Len(strTemp) If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strLaufwerk & strTemp) And vbDirectory) = vbDirectory Then If bolWeiter = True Then Dateisuche strLaufwerk & strTemp, strDatei Else Exit Function strWdhlg = Dir(strLaufwerk, vbDirectory) Do While strWdhlg <> strTemp: strWdhlg = Dir(): Loop End If End If strTemp = Dir() Loop End Function

Zweite Möglichkeit:

Sub suchen1() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dateisuche fso.GetFolder("C:"), "test.txt" Set fso = Nothing End Sub Sub Dateisuche(objErstOrdner As Object, strDatei As String) Dim objDatei As Object, objOrdner As Object, sf As Object For Each objDatei In objErstOrdner.Files If LCase(objDatei.Name) = strDatei Then MsgBox objDatei.Path End If Next For Each objOrdner In objErstOrdner.SubFolders Dateisuche objOrdner, strDatei Next End Sub

Datei ▸ Öffnen

Die wohl bekannteste Variante für den Öffnen-Dialog, mit der man die Auswahl komfortabel abfragen kann:

Dim varPfad varPfad = Application.GetOpenFilename("CSV-Dateien (*.csv), *.csv") If varPfad <> False Then Workbooks.Open Filename:=varPfad

Oder so:

With Application.FileDialog(msoFileDialogOpen) .Filters.Clear .Filters.Add "CSV-Dateien", "*.csv" .InitialFileName = "C:\Temp\" 'Ordner vorbelegen If .Show = -1 Then MsgBox .SelectedItems(1) End With

Hier wird eine gewählte Datei geöffnet:

Select Case Application.Dialogs(xlDialogOpen).Show("test.xls") Case -1: MsgBox "Geöffnet" Case 0: MsgBox "Abgebrochen" End Select

Datei ▸ Speichern unter

1. Möglichkeit (In A1 steht der Dateiname.):

Dim varPfad varPfad = Application.GetSaveAsFilename(Range("A1")) If varPfad = False Then Exit Sub ActiveWorkbook.SaveAs varPfad

2. Möglichkeit:

Dim varPfad varPfad = Application.Dialogs(xlDialogSaveAs).Show("test.xls") Select Case varPfad Case -1 'Gesichert Case 0 'Abgebrochen End Select

Eine Ãœbersicht zu integrierten Dialogfeldern finden Sie in Integrierte Dialogfelder aufrufen

Eigentlich gar nicht.

Man kann aber mit einer Formel Bezug auf eine geschlossene Mappe nehmen; deren Ergebnis erscheint dann. Dies kann man dann mit VBA verwenden. Also kann man auch mit VBA die Formel eintragen und dann das Ergebnis abgreifen. Die Formel kann zum Schluss wieder gelöscht wreden.

Beispiel:
Im Ordner C:\Eigene Dateien befindet sich die Datei DBAdressen.xlsx. Aus dieser Datei sollen vom Blatt Allgemein die Daten aus A1 bis A25 in eine Listbox eingelesen werden, ohne diese Datei zu öffnen.

Const strBezug As String = "='C:\Eigene Dateien\[DBAdressen.xlsx]Allgemein'!$A$" 'Folgende Scheife schreibt nacheinander die Formel in B2 und fügt der Listbox 'dann das Ergebnis der Formel hinzu. Private Sub CommandButton1_Click() Dim intI As Integer ListBox1.Clear Application.DisplayAlerts = False For intI = 1 To 25 Range("B1").Formula = strBezug & intI If Not IsError(Range("B1")) Then ListBox1.AddItem Range("B1").Text Next Range("B1") = "" Application.DisplayAlerts = True End Sub

Das Ganze kann (und sollte) natürlich mit Errorhandlings verfeinert werden.

Die verschiedenen Deklarationen sind wichtig, um das Funktionieren sowohl in der 64-Bit-Version des Microsoft Office (also nicht von Windows) als auch in der 32-Bit-Version zu gewährleisten.

#If VBA7 Then Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As LongPtr) As LongPtr #Else Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long #End If Sub ComputerName() Dim lngTemp As LongPtr, strPCName As String strPCName = Space(256) lngTemp = GetComputerName(strPCName, Len(strPCName)) MsgBox strPCName End Sub

Das kann man natürlich auch als UDF erstellen:

Function ComputerName1() Dim lngTemp As LongPtr, strPCName As String strPCName = Space(256) lngTemp = GetComputerName(strPCName, Len(strPCName)) ComputerName1 = strPCName End Function

In die Zelle wird einfach =computername1() eingetragen.

Die folgende Funktion speichert mit Environ() den lokalen OneDrive-Ordner in eine Variable. Anschließend ersetzt sie im Pfad der Datei diverse mögliche Zeichenfolgen, die OneDrive selbst vergibt. Mit einem regulären Ausdruck wird dann der OneDrive-Teil im Pfad der Datei durch den lokalen Pfad ersetzt.

Ggf. können noch ein paar Fehlerbehandlungen eingebaut werden.

Function OneDrive2Lokal(ByVal strPfad As String) As String Dim strOnedrivePfad As String, RegEx As Object, regMatches OneDrive2Lokal = "" If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") If Left(strPfad, 6) = "https:" Then strOnedrivePfad = Environ("OneDrive") & "\" ' oder "OneDriveConsumer" strPfad = Replace(strPfad, "^J", ",") strPfad = Replace(strPfad, "^N", "#") strPfad = Replace(strPfad, "^0", "&") RegEx.Pattern = "^(https:/{2}[A-Za-z0-9./]+/)" Set regMatches = RegEx.Execute(strPfad) strPfad = Replace(RegEx.Replace(strPfad, strOnedrivePfad), "/", "\") End If OneDrive2Lokal = strPfad Set RegEx = Nothing End Function

Die Funktion kann beliebig verwendet werden, zum Beispiel:

MsgBox OneDrive2Lokal(ThisWorkbook.FullName)