Office: Dialogfeld Datei öffnen mit Pfad- und Dateivorgabe

User · 12. Juni 2011

Hallo zusammen,

ich brauch schon wieder Eure Hilfe.

Kann ich ein Dialogfeld zum Datei öffnen so erstellen, dass ein Dateipfad hinterlegt ist und nur bestimmte Datein (Excel --> Hauptsächlich xml-Dateien) angezeigt werden?

Besten Dank & Gruß
Sandra

:)

EarlFred · 13. Juni 2011

Hallo Sandra,

probier mal:
Code:

Option Explicit
Sub aufmachen()
Dim strDateiName As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = "C:\DeinPfad\*.xml"
If .Show = -1 Then
strDateiName = .SelectedItems(1)
End If
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

User · 13. Juni 2011

Hallo EarlFred,

das klappt.

Allerdings klappt das mit der xml-Datei so besser:

Code:

Dim strDateiName As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = "\\xxx.xxx.xx.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\.xml"
If .Show = -1 Then
strDateiName = .SelectedItems(1)
End If
End With
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Also ohne * vor .xml. Mit Sternchen zeigt er mir nämlich alle enthaltenen Dateien an.

Aber jetzt hab ich ein anderes Problem und weiß nicht, wo es herkommt.

Ich hatte bis dato ein funktionierendes, projektbezogenes Makro. Nun muss ich diese Makro standardisieren, damit alle Kollegen damit arbeiten können. Daher jetzt auch das Dialogfeld, mit dem man die benötigte Datei händisch öffnen kann.

Vorher wurde die Datei automatisch geändert.

So sah es aus:

Code:

Sub Standard_Maengelliste()

Dim oXlSM As Workbook, oXML As Workbook
Dim nIndexXLSM, nIndexXLM, MaxRow As Long, nIndex As Long
Dim rngXLSM As Range, rngXML As Range, ArrayXLSM
Dim strFehler As String
Dim ArrayQuelle, ArrayZiel
Const sListZeichen$ = " "

'hier stehen die Überschriften, nach denen gesucht wird
'Wichtig! Die Reihenfolge muss bei beiden identisch sein

ArrayQuelle = Array("Betrifft", "verortete Zustandsbeschreibung", "Mangelart", "Vertragsart", "Gewerke-gruppe", "Gewerk", "Bauabschnitt", "Geschoss", "Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "strittig", "sicherheitsrelevant", "betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher", "Nachweis fehlt")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", "Gewerkegruppe", "Gewerk", "Bauabschnitt", "Geschoss", "Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "strittig", "sicherheitsrelevant", "betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher", "Nachweis fehlt")

'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist

Set oXML = Workbooks.Open(Filename:= _
"\\xxx.xxx.xx.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\xxxx xxxxxx\" & _
"xxxx xxxxxx\xxx xxxxxxx xxxxxxxxxxxxxxxxxxxx.xml")

Set oXlSM = ThisWorkbook 'ThisWorkbook = die xlsm-Datei, in der dieser Code steht

For nIndex = LBound(ArrayQuelle) To UBound(ArrayQuelle)

With oXlSM.Sheets("Mängel vor der Abnahme") 'Name des Tabellenblattes, welches in der xlsm-Datei benutzt wird
nIndexXLSM = Application.Match(ArrayQuelle(nIndex), .Rows(2), 0) 'sucht in der Zeile 2 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLSM) Then
MaxRow = .Cells(.Rows.Count, nIndexXLSM).End(xlUp).Row 'letzte Zeile in Spalte

Set rngXLSM = .Range(.Cells(3, nIndexXLSM), .Cells(MaxRow, nIndexXLSM))
If MaxRow > 3 Then
ArrayXLSM = rngXLSM
ElseIf MaxRow = 3 Then
ArrayXLSM = rngXLSM.Resize(, 2)
ReDim Preserve ArrayXLSM(1 To UBound(ArrayXLSM), 1 To 1)

End If

'Fehlermeldung die ausgegeben wird, wenn eine festgelegte Spaltenüberschrift nicht in der xlsm-Datei gefunden werden konnte

strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayQuelle(nIndex) & "' wurde nicht in der Quell-Datei gefunden" & vbCr
End If
End With

If IsArray(ArrayXLSM) Then
With oXML.Sheets("neue Zustandsbeschreibungen") 'Name des Tabellenblattes, welches in der xml-Datei benutzt wird
nIndexXML = Application.Match(ArrayZiel(nIndex), .Rows(64), 0) 'sucht in der Zeile 64 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLM) Then

'alle Inhalte der Zellen ab Zeile 65 werden für neue Daten gelöscht

.Range(.Cells(65, nIndexXML), .Cells(.Rows.Count, nIndexXML)).ClearContents
Set rngXLM = .Cells(65, nIndexXML) 'erste Einfügezelle
rngXLM.Resize(UBound(ArrayXLSM), 1) = ArrayXLSM 'Daten aus Array einfügen
Else
strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayZiel(nIndex) & "' wurde nicht in der Ziel-Datei gefunden" & vbCr
End If
End With
End If
ArrayXLSM = Empty
Next nIndex

Dim Sh_neue_Zustandsbeschreibungen As Worksheet
Dim iCalc As Long
On Error GoTo ErrExit
Set Sh_neue_Zustandsbeschreibungen = Sheets("neue Zustandsbeschreibungen") 'hier wird das Tabellenblatt beschrieben, wo die Leerzeilen gelöscht werden sollen
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'hier erfolgt die Abschaltung des Blattschutzes

With Sh_neue_Zustandsbeschreibungen
.Unprotect

'hier werden Zeilen die komplett leer sind gelöscht

With .UsedRange.Columns(.UsedRange.Columns.Count).Offset(0, 1)
.FormulaR1C1 = "=IF(AND(ROW()>65,RC1&RC2=""""),TRUE(),ROW())"
Sh_neue_Zustandsbeschreibungen.UsedRange.Sort .Cells(1, 1), xlAscending, , , , , , xlNo
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
On Error GoTo ErrExit
.EntireColumn.Delete
End With

'hier wird der Blattschutz wieder aktiviert

.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True
End With
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
Set Sh_neue_Zustandsbeschreibungen = Nothing

'hier erfolgt die Prüfung nach ggf. vergessenen Zellen

Dim zeile As Long, spalte As Long
Dim i As Integer
Dim strausgabe As String, strzelle As String, x As String
Dim wks As Worksheet
Dim check As Boolean
Set wks = Sheets(1)
Dim spalten()
Dim spaltennamen()
Dim spaltenausgabe()
x = ""
spalten() = Array(4, 5, 7, 15, 18)
spaltennamen() = Array("Mangelart", "Vertragsart", "Gewerk", "Frist", "Auftragnehmer")
spaltenausgabe() = Array(x, x, x, x, x, x, x, x)
For i = 0 To UBound(spalten())
spaltenausgabe(i) = spaltennamen(i) & " in den Zeilen: "
Next i
With wks
For zeile = 65 To 500
If .Cells(zeile, 2).Value "" Then
For i = 0 To UBound(spalten())
On Error GoTo schleife
If Cells(zeile, spalten(i)).Value = 0 Then
schleife:
spaltenausgabe(i) = spaltenausgabe(i) & zeile & ", "
check = True
End If
Next i
End If
Next zeile
End With
If check = True Then
For i = 0 To UBound(spalten())
strausgabe = strausgabe & spaltenausgabe(i) & vbCrLf
Next i
MsgBox "Fehlerhaft ausgefüllte Zellen in: " & vbCrLf & _
strausgabe
Else
MsgBox "keine Leer- oder Nullwerte in den zu prüfenden Zellen gefunden!"
End If

'speichern der xlm-Datei

ActiveWorkbook.SaveAs Filename:="\\xxx.xxx.xx.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\xxxx xxxxxx\xxxx xx xxxx\xxxxxxxxxxxxx\" & _
Format(Date, "yymmdd") & " xxx xxxxxxxxxxxxxxxxxxxx " & Format(Time, "hhmm") & " Uhr.xml"

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Da lief alles. Jetzt bin ich beim umschreiben. Der aktuelle (aber nicht finale) Stand ist:

Code:

Sub Standard_Maengelliste()

Dim oXlSM As Workbook, oXML As Workbook
Dim nIndexXLSM, nIndexXLM, MaxRow As Long, nIndex As Long
Dim rngXLSM As Range, rngXML As Range, ArrayXLSM
Dim strFehler As String
Dim ArrayQuelle, ArrayZiel
Const sListZeichen$ = " "

'hier stehen die Überschriften, nach denen gesucht wird
'Wichtig! Die Reihenfolge muss bei beiden identisch sein

ArrayQuelle = Array("Betrifft", "verortete Zustandsbeschreibung", "Mangelart", "Vertragsart", "Gewerke-gruppe", "Gewerk", _
"Bauabschnitt", "Geschoss", "Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", _
"Auftragnehmer", "strittig", "sicherheitsrelevant", "betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher", _
"Nachweis fehlt")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", "Gewerkegruppe", "Gewerk", "Bauabschnitt", _
"Geschoss", "Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "strittig", _
"sicherheitsrelevant", "betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher", "Nachweis fehlt")

'hier wird mittels einer "Info-Box" darauf hingewiesen, dass im nächsten Schritt die uploadfähige xml-Datei geöffnet werden muss

MsgBox "Im nächsten Schritt müsst Ihr nun entsprechend Eures Projektes die uploadfähige xml-Datei öffnen, die in jedem Projekte-Ordner unter 0000 MUSTER abgelegt sein sollte."

'mit diesem Befehl öffnet sich ein Dialogfeld zum öffnen einer Datei

Dim strDateiName As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = "\\xxx.xxx.xx.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\.xml"
If .Show = -1 Then
strDateiName = .SelectedItems(1)
End If
End With

Set oXML = ThisWorkbook
Set oXlSM = ThisWorkbook 'ThisWorkbook = die xlsm-Datei, in der dieser Code steht

For nIndex = LBound(ArrayQuelle) To UBound(ArrayQuelle)

With oXlSM.Sheets("Mängel vor der Abnahme") 'Name des Tabellenblattes, welches in der xlsm-Datei benutzt wird
nIndexXLSM = Application.Match(ArrayQuelle(nIndex), .Rows(2), 0) 'sucht in der Zeile 2 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLSM) Then
MaxRow = .Cells(.Rows.Count, nIndexXLSM).End(xlUp).Row 'letzte Zeile in Spalte

Set rngXLSM = .Range(.Cells(3, nIndexXLSM), .Cells(MaxRow, nIndexXLSM))
If MaxRow > 3 Then
ArrayXLSM = rngXLSM
ElseIf MaxRow = 3 Then
ArrayXLSM = rngXLSM.Resize(, 2)
ReDim Preserve ArrayXLSM(1 To UBound(ArrayXLSM), 1 To 1)

End If

'Fehlermeldung die ausgegeben wird, wenn eine festgelegte Spaltenüberschrift nicht in der xlsm-Datei gefunden werden konnte

strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayQuelle(nIndex) & "' wurde nicht in der Quell-Datei gefunden" & vbCr
End If
End With

If IsArray(ArrayXLSM) Then
With oXML.Sheets("neue Zustandsbeschreibungen") 'Name des Tabellenblattes, welches in der xml-Datei benutzt wird
nIndexXML = Application.Match(ArrayZiel(nIndex), .Rows(64), 0) 'sucht in der Zeile 64 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLM) Then

'alle Inhalte der Zellen ab Zeile 65 werden für neue Daten gelöscht

.Range(.Cells(65, nIndexXML), .Cells(.Rows.Count, nIndexXML)).ClearContents
Set rngXLM = .Cells(65, nIndexXML) 'erste Einfügezelle
rngXLM.Resize(UBound(ArrayXLSM), 1) = ArrayXLSM 'Daten aus Array einfügen
Else
strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayZiel(nIndex) & "' wurde nicht in der Ziel-Datei gefunden" & vbCr
End If
End With
End If
ArrayXLSM = Empty
Next nIndex

Dim Sh_neue_Zustandsbeschreibungen As Worksheet
Dim iCalc As Long
On Error GoTo ErrExit
Set Sh_neue_Zustandsbeschreibungen = Sheets("neue Zustandsbeschreibungen") 'hier wird das Tabellenblatt beschrieben, wo die Leerzeilen gelöscht werden sollen

With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'hier erfolgt die Abschaltung des Blattschutzes

With Sh_neue_Zustandsbeschreibungen
.Unprotect

'hier werden Zeilen die komplett leer sind gelöscht

With .UsedRange.Columns(.UsedRange.Columns.Count).Offset(0, 1)
.FormulaR1C1 = "=IF(AND(ROW()>65,RC1&RC2=""""),TRUE(),ROW())"
Sh_neue_Zustandsbeschreibungen.UsedRange.Sort .Cells(1, 1), xlAscending, , , , , , xlNo
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
On Error GoTo ErrExit
.EntireColumn.Delete
End With

'hier wird der Blattschutz wieder aktiviert

.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True
End With
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
Set Sh_neue_Zustandsbeschreibungen = Nothing

'hier erfolgt die Prüfung nach ggf. vergessenen Zellen

Dim zeile As Long, spalte As Long
Dim i As Integer
Dim strausgabe As String, strzelle As String, x As String
Dim wks As Worksheet
Dim check As Boolean
Set wks = Sheets(1)
Dim spalten()
Dim spaltennamen()
Dim spaltenausgabe()
x = ""
spalten() = Array(4, 5, 7, 15, 18)
spaltennamen() = Array("In der Spalte Mangelart (E)", "In der Spalte Vertragsart (F)", "In der Spalte Gewerk (G)", _
"In der Spalte Frist (O)", "In der Spalte Auftragnehmer (R)")
spaltenausgabe() = Array(x, x, x, x, x, x, x, x)
For i = 0 To UBound(spalten())
spaltenausgabe(i) = spaltennamen(i) & " in den Zeilen: "
Next i
With wks
For zeile = 65 To 500
If .Cells(zeile, 2).Value "" Then
For i = 0 To UBound(spalten())
On Error GoTo schleife
If Cells(zeile, spalten(i)).Value = 0 Then
schleife:
spaltenausgabe(i) = spaltenausgabe(i) & vbCrLf & zeile & ", " & vbCrLf
check = True
End If
Next i
End If
Next zeile
End With
If check = True Then
For i = 0 To UBound(spalten())
strausgabe = strausgabe & spaltenausgabe(i) & vbCrLf
Next i
MsgBox "Fehlerhaft ausgefüllte Zellen: " & vbCrLf & vbCrLf & _
strausgabe
Else
MsgBox "Es konnten keine leeren Zellen in den Spalten Mangelart (E), Vertragsart (F), Gewerk (G), Frist (O) und Auftragnehmer (R) gefunden werden!"
End If

'hier wird mittels einer "Info-Box" darauf hingewiesen, dass im nächsten Schritt der Speicherort für die uploadfähige xml-Datei ausgewählt werden muss

MsgBox "Im nächsten und letzten Schritt müsst Ihr nun entsprechend Eures Projektes auswählen, wo Eure uploadfähige xml-Datei gespeichert werden soll. Sinnvoll ist dies gem. der QM-Ablagestruktur. Der Stand am 14.06.2011 ist, dass die Ablage im jeweiligen Projektordner, entsprechend des Gewerkes, unter Dokumentation erfolgt."

'speichern der xlm-Datei

ActiveWorkbook.SaveAs Filename:="\\xxx.xxx.x.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\xxxx xxxxxx\xxxx xx xxxx\xxxxxxxxxxxxx\" & _
Format(Date, "yymmdd") & " xxx xxxxxxxxxxxxxxxxxxxx " & Format(Time, "hhmm") & " Uhr.xml"

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Und hier tritt jetzt an dieser Stelle:

Code:

If IsArray(ArrayXLSM) Then
With oXML.Sheets("neue Zustandsbeschreibungen") 'Name des Tabellenblattes, welches in der xml-Datei benutzt wird
nIndexXML = Application.Match(ArrayZiel(nIndex), .Rows(64), 0) 'sucht in der Zeile 64 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLM) Then
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

In der Zeile
Code:

With oXML.Sheets("neue Zustandsbeschreibungen") 'Name des Tabellenblattes, welches in der xml-Datei benutzt wird
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

eine Fehlermeldung auf.

Laufzeitfehler '9':
Index außerhalb es gültigen Bereichs

Wenn ich mit der Maus af oXML.Sheets gehe steht da:
oXML.Sheets("neue Zustandsbeschrei... = Index außerhalb des gültigen Bereichs

Wo ist denn hier mein Fehler? Muss ich doch mehr ändern als gedacht?

Es wär klasse, wenn Du mir dabei helfen könntest.

Danke & Gruß
Sandra

EarlFred · 13. Juni 2011

Hallo Sandra,

Also ohne * vor .xml. Mit Sternchen zeigt er mir nämlich alle enthaltenen Dateien an.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Interessantes Verhalten. Welche Excel-Version nutzt Du? Bei 2003 erhalte ich wie erwartet eine Fehlermeldung, wenn "*" fehlt.

Dein Code ermittelt zwar den Dateinamen, öffnet aber nicht die gewählte Datei.
Code:

Set oXML = ThisWorkbook
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ist bestimmt nicht richtig, denn Du willst Dich doch nicht auf das Workbook beziehen, in dem der Code steht (Thisworkbook), sondern auf das, welches Du öffnen willst?
Analog des unbearbeiteten Codes:
Code:

Set oXML = Workbooks.Open(Filename:= strDateiName)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

User · 13. Juni 2011

Hallo EarlFred,

das hätte ich vielleicht erwähnen sollen.

Ich benutze Office 2010.

Deine Änderung klappt. Ich dachte das durch oXML klar ist, dass mit ThisWorkbook die xlm-Datei gemeint ist.

Da hatte ich wohl (wie so oft) einen Denkfehler.

Dann erst einmal an dieser Stelle: VIELEN DANK & EINEN SCHÖNEN TAG.

Ich schreibe später bestimmt noch einmal zu einer anderen Problematik.

Liebe Grüße
Sandra

Office: Dialogfeld Datei öffnen mit Pfad- und Dateivorgabe

Dialogfeld Datei öffnen mit Pfad- und Dateivorgabe

Dialogfeld Datei öffnen mit Pfad- und Dateivorgabe

Dialogfeld Datei öffnen mit Pfad- und Dateivorgabe

Dialogfeld Datei öffnen mit Pfad- und Dateivorgabe - Similar Threads - Dialogfeld Datei öffnen

Das Feld "Endet am" wird im Dialogfeld "Terminserie" nicht korrekt angezeigt

Dialogfeld ' Datenquelle bearbeiten '

Dialogfeld ' Abfrageoptionen sortieren '

Das Dialogfeld „Schriftart ersetzen“ zeigt nur Schriftarten der PowerPoint-Präsentation

Verwenden des Dialogfelds "Suchen und Ersetzen" zum Ändern von Daten

Dialogfeld "Datentasks verwalten"

Word 2007 - Dialogfeld "Datei öffnen" in/mit Makro