Pfad und Dateiname

[Peter Schuerer]

Hallo Zusammen,

XL2002.

Ich benötige dringend ein Makro mit dem ich den DateiÖffnenDialog
aufrufen kann. Im Dialog eine oder auch mehrere Dateien auswählen kann
und nach Auswahl wird der Pfad in Tabelle1 A3 und der Dateiname in B3
eingetragen.
Das Ganze für bis zu 7 Dateien.
Wenn in A3 etwas steht, soll in A4 eingetragen werden.

Weiterhin verwende ich folgendes Makro:
Public Sub HoleDaten_Platten()

Application.ScreenUpdating = False
Dim Pfad As String
Dim Dateiname As String
Dim Blatt As String

Pfad = [Tabelle1].Range("C3").Text
Dateiname = [Tabelle1].Range("C4").Text
Blatt = [Tabelle1].Range("C5").Text

If GetDataClosedWB(Pfad, _
Dateiname, _
Blatt, _
"A2:L6000", _
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)) Then
MsgBox "Daten importiert"
End If
Application.ScreenUpdating = True
End Sub

Bisher waren Pfad, Dateiname und Blatt fest vorgegeben. Geht so aber
nicht, da sich der Dateiname ändert.
Habe jetzt versucht, die einzelnen Angaben aus Tabelle1 zu entnehmen.
Egal ob ich .Value oder .Text verwende, es wird als Pfad, Dateiname und
Blatt immer "1" angezeigt.
Bitte dringend um Hilfe.

Danke und Gruß
Peter

---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo Peter,

Post by Peter Schuerer
Ich benötige dringend ein Makro mit dem ich den DateiÖffnenDialog
aufrufen kann. Im Dialog eine oder auch mehrere Dateien auswählen kann
und nach Auswahl wird der Pfad in Tabelle1 A3 und der Dateiname in B3
eingetragen.
Das Ganze für bis zu 7 Dateien.
Wenn in A3 etwas steht, soll in A4 eingetragen werden.

für jeweils eine Datei get es so:

Sub Test()
Dim i As Integer

Application.Dialogs(xlDialogOpen).Show
With ThisWorkbook.Sheets("Tabelle1")
i = WorksheetFunction.Max(3, _
.Cells(.Rows.Count, 1).End(xlUp)(2).Row)
.Cells(i, 1) = ActiveWorkbook.Path
.Cells(i, 2) = ActiveWorkbook.Name
End With
End Sub

Hast du dir mein Makro (in der anderen Frage) mit dem Mappenöffnen schon
angesehen? Dort kannst du alle Mappen, die mit dem gleichen Teilstring
beginnen, automatisch öffnen lassen.


Mit freundlichen Grüßen
Claus

[Peter Schuerer]

Hallo Claus,

Post by Claus Busch
Hast du dir mein Makro (in der anderen Frage) mit dem Mappenöffnen schon
angesehen? Dort kannst du alle Mappen, die mit dem gleichen Teilstring
beginnen, automatisch öffnen lassen.

Ich habe mir dein Makro angesehen, habe aber leider bis jetzt um 3 Ecken
gedacht.
Der Endanwender schickt mir den kompletten Pfad, wo die Dateien
(einschließlich diese) gespeichert werden. Diesen Pfad möchte ich in das
Makro einbauen.

Jetzt noch eine Frage, was wenn sich der Pfad oder/und Tabellenname ändert?
In Tabelle1 A1 wird der aktuelle Pfad (dieser Datei per Formel) eingetragen.

Sub DatenKopieren()
Dim objFSO As Object
Dim objOrdner As Object
Dim objDatei As Object
Dim FERow As Range

- Hier möchte ich gern den Pfad aus "Tabelle1 A1" übernehmen.
Const Pfad = "d:\eMail\Becker\Test\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

On Error Resume Next

-Die sollen sehen das etwas passiert und was passiert.
'Application.ScreenUpdating = False

Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
For Each objDatei In objOrdner.Files
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy _

- Hier möchte ich nicht "Sheets" verwenden, sondern den internen Namen
[Tabelle2]
ThisWorkbook.Sheets("Tabelle1") _
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
ActiveWorkbook.Close savechanges:=False
End With
End If
Next
Application.ScreenUpdating = True
End Sub

Ansonsten ist es der einfachste Weg, das zu erreichen was ich
wollte/sollte. ;-)
Noch ein kleines Problem. In den einzelnen Dateien gibt es Formatierung,
Text Standard, Text Fett und Rot ... Diese Formatierungen sollen nicht
mit übernommen werden.
Also Daten einfach ohne Formatierung einfügen.

Danke und Gruß
Peter

---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo Peter,

Am Mon, 28 Oct 2013 08:00:35 +0100 schrieb Peter Schuerer:

Mit ScreenUpdating = false läuft das Makro schneller und ruckt nicht
durch die Mappen und Seiten. Falls sich Tabellennamen und Zelle ändern,
ist das im Code ja schnell korrigiert.Soll wirklich Tabelle2 vorher
gelöscht werden?

dann probiere es mal so:

Sub DatenKopieren2()
Dim objFSO As Object
Dim objOrdner As Object
Dim objDatei As Object
Dim FERow As Range
Dim LRow As Long
Dim LCol As Integer
Dim Pfad As String

Pfad = Tabelle1.Range("A1")
With Tabelle2
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(3, 1), .Cells(LRow, LCol)).ClearContents
End With

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

On Error Resume Next

Application.DisplayAlerts = False
For Each objDatei In objOrdner.Files
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy
End With
ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveWorkbook.Close savechanges:=False
End If
Next
Application.DisplayAlerts = True
End Sub


Mit freundlichen Grüßen
Claus

[Peter Schuerer]

Hallo Claus,

Soweit funktioniert das Makro wie gewünscht, wunderbar.
In Zeile 2 stehen Überschriften und seltsamerweise wird der Wert in A2
gelöscht.

Wäre es auch noch möglich, Unterordner mit einzubeziehen?
Die Pfade zu den Dateien sehen so aus:
K:\Produktion\Umlaufdokumente\Datenerfassung\Gruppe 5 Band 5\
K:\Produktion\Umlaufdokumente\Datenerfassung\Gruppe 5 Band 4\
K:\Produktion\Umlaufdokumente\Datenerfassung\Gruppe 8 Band 5\
Diese Datei sollte in den Ordner "Datenerfassung" und müsste diesen
Ordner und alle Unterordner nach Dateien mit "PEP" durchsuchen.
Wenn es nicht geht, auch nicht schlimm.

Sub DatenKopieren2()
Dim objFSO As Object
Dim objOrdner As Object
Dim objDatei As Object
Dim FERow As Range
Dim LRow As Long
Dim LCol As Integer
Dim Pfad As String

Pfad = Tabelle2.Range("O1")
With Tabelle2
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(3, 1), .Cells(LRow, LCol)).ClearContents
End With

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

' On Error Resume Next

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For Each objDatei In objOrdner.Files
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy
End With
Tabelle2.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveWorkbook.Close savechanges:=False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Alle Daten wurden eingefügt"
End Sub


Danke und Gruß
Peter


---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo Peter,

Post by Peter Schuerer
Soweit funktioniert das Makro wie gewünscht, wunderbar.
In Zeile 2 stehen Überschriften und seltsamerweise wird der Wert in A2
gelöscht.

Ich wußte nicht, dass Überschriften darin sind. Wenn LRow kleiner ist
als 3, setzt sich der zu löschende Range anders zusammen. HAbe es
geändert.

Post by Peter Schuerer
Wäre es auch noch möglich, Unterordner mit einzubeziehen?

Ich kann deine Vorgaben hier nicht nachstellen, deswegen ist der Teil
des Makros mit den Unterordnern ungetestet, sollte aber funktionieren:

Sub DatenKopieren3()
Dim objFSO As Object
Dim objOrdner As Object
Dim objDatei As Object
Dim objSubordner As Object
Dim FERow As Range
Dim LRow As Long
Dim LCol As Integer
Dim Pfad As String

Pfad = Tabelle1.Range("A1")
With Tabelle2
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(3, 1), .Cells(LRow + 1, LCol)).ClearContents
End With

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

On Error Resume Next

Application.DisplayAlerts = False
For Each objDatei In objOrdner.Files
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy
End With
ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveWorkbook.Close savechanges:=False
End If
Next

For Each objSubordner In objOrdner.SubFolders
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy
End With
ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveWorkbook.Close savechanges:=False
End If
Next

Application.DisplayAlerts = True
End Sub



Mit freundlichen Grüßen
Claus

[Claus Busch]

Hallo Peter,

Post by Claus Busch
For Each objSubordner In objOrdner.SubFolders
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy
End With
ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveWorkbook.Close savechanges:=False
End If
Next

bei den SubOrdnern ist doch ein Fehler drin.

Ändere so ab:

For Each objSubOrdner In objOrdner.subfolders
For Each objDatei In objSubOrdner.Files
If Left(objDatei.Name, 3) = "PEP" Then
Workbooks.Open Pfad & objSubOrdner.Name _
& "\" & objDatei.Name
With ActiveWorkbook.Sheets("DBPers")
.Range("A2:L" & .UsedRange.Rows.Count).Copy
End With
ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveWorkbook.Close savechanges:=False
End If
Next
Next


Mit freundlichen Grüßen
Claus

[Peter Schuerer]

Hallo Claus,

Post by Claus Busch
bei den SubOrdnern ist doch ein Fehler drin.

Tausend Dank, jetzt funktioniert es wunderbar. :-))

Danke und Gruß
Peter

---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo Peter,

Post by Peter Schuerer
Tausend Dank, jetzt funktioniert es wunderbar. :-))

schön, dass es jetzt funktioniert. Danke für die Rückmeldung.

Wenn dein Blatt mit dem Pfad den Namen ändern kann, aber immer das erste
Blatt in der Mappe ist, sprich es doch mit Worksheets(1) an.


Mit freundlichen Grüßen
Claus

[Peter Schuerer]

Hallo Claus,

Post by Claus Busch
Wenn dein Blatt mit dem Pfad den Namen ändern kann, aber immer das erste
Blatt in der Mappe ist, sprich es doch mit Worksheets(1) an.

Meine Tabelle ist nicht die erste Tabelle und der Name und Position kann
sich ändern.
Im VBA-Editor steht bei den Tabellen:
Tabelle2 (Personalzeit).
Den VBA internen Namen kann man doch verwenden mit:
[Tabelle2].....

Oder liege ich da falsch und es gibt Probleme bei der Anwendung?
Bisher verwende ich:
[Tabelle2].Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
und es funktioniert.


Danke und Gruß
Peter

---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo Peter,

Post by Peter Schuerer
[Tabelle2].....

den Codenamen des Blattes kannst du natürlich auch verwenden. Das
funktioniert aber nur, wenn die Mappe aktiv ist, denn die Mappen, die
geöffnet werden, haben bestimmt auch ein Blatt mit dem Codenamen
[Tabelle2]


Mit freundlichen Grüßen
Claus

[Peter Schuerer]

Hallo Claus,

Post by Claus Busch
den Codenamen des Blattes kannst du natürlich auch verwenden. Das
funktioniert aber nur, wenn die Mappe aktiv ist, denn die Mappen, die
geöffnet werden, haben bestimmt auch ein Blatt mit dem Codenamen
[Tabelle2]

Mein Problem bei dieser Datei, sie wird weiter gegeben, die Anwender
benennen Tabellen um und verändern die Reihenfolge.

Ich habe jetzt mal (per Makro) 100 neue Tabellen eingefügt, alle bis auf
die letzte gelöscht und habe jetzt als Codename der Tabelle [Tabelle103].
Damit sollte es keine Probleme geben.

Danke und Gruß
Peter


---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo Peter,

Post by Peter Schuerer
Ich habe jetzt mal (per Makro) 100 neue Tabellen eingefügt, alle bis auf
die letzte gelöscht und habe jetzt als Codename der Tabelle [Tabelle103].
Damit sollte es keine Probleme geben.

das wäre nicht nötig gewesen. Den Codenamen kannst du im
Eigenschaftenfenster der Tabelle im VBA-Editor ändern. In diesem
Eigenschaftenfenster gibt es Name und (Name). Der Name in Klammern ist
der Codename und den kannst du im Eigenschaftenfenster auch ändern.

Wenn du Ereignismakros in den Mappen hast, kannst du vor dem Öffnen
Application.EnableEvents=False setzen und am Ende des Codes wieder auf
true


Mit freundlichen Grüßen
Claus

[Claus Busch]

Hallo Peter,

Post by Claus Busch
Wenn du Ereignismakros in den Mappen hast, kannst du vor dem Öffnen
Application.EnableEvents=False setzen und am Ende des Codes wieder auf
true

falls das deaktivieren der Events nicht ausreichend sein sollte, schau
mal in der VBA-Hilfe nach:
Application.AutomationSecurity-Eigenschaft


Mit freundlichen Grüßen
Claus

[Peter Schuerer]

Hallo Claus,

Post by Claus Busch
Den Codenamen kannst du im
Eigenschaftenfenster der Tabelle im VBA-Editor ändern. In diesem
Eigenschaftenfenster gibt es Name und (Name). Der Name in Klammern ist
der Codename und den kannst du im Eigenschaftenfenster auch ändern.
Wenn du Ereignismakros in den Mappen hast, kannst du vor dem Öffnen
Application.EnableEvents=False setzen und am Ende des Codes wieder auf
true

Damit hat sich mein Problem erledigt.
Den Codenamen der Tabelle habe ich geändert und die
"Application.EnableEvents=False" habe ich eingefügt.
Bis jetzt funktioniert alles, mal sehen was noch so passiert.


Danke und Gruß
Peter

---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Peter Schuerer]

Hallo Claus,

Post by Claus Busch
den Codenamen des Blattes kannst du natürlich auch verwenden.

Noch eine kleine Frage:

Durch Dein Makro werden die erforderlichen Dateien geöffnet. Beim öffnen
der Dateien werden aber Makros ausgeführt (auto_open, Diese Arbeitsmappe).
Kann man das starten der Makros irgendwie unterbinden.
Also einfach erforderliche Datei öffnen, keine Makros ausführen, Daten
kopieren, Daten einfügen, geöffnete Datei schließen?

Danke und Gruß
Peter


---
Diese E-Mail ist frei von Viren und Malware, denn der avast! Antivirus Schutz ist aktiv.
http://www.avast.com

[Claus Busch]

Hallo nochmals,

für mehrere Dateien dann:

Sub Test()
Dim i As Integer
Dim wbk As Workbook

Application.Dialogs(xlDialogOpen).Show
For Each wbk In Workbooks
With ThisWorkbook.Sheets("Tabelle1")
If wbk.Name <> ThisWorkbook.Name Then
i = WorksheetFunction.Max(3, _
.Cells(.Rows.Count, 1).End(xlUp)(2).Row)
.Cells(i, 1) = wbk.Path
.Cells(i, 2) = wbk.Name
End If
End With
Next
End Sub


Mit freundlichen Grüßen
Claus