Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 10:59:29
Datei Auswählen und öffnen
19.04.2024 10:46:47
Bestimmte Zellen aus dynamischer Liste zurückgeben
19.04.2024 10:39:36
Schaltfläche auf einem Tabellenblatt NICHT mit abspeichern
19.04.2024 09:26:26
Median für Zeilen mit gleichen Zeitstempel
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1332to1336
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1332to1336
1332to1336
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Verzeichnisse suchen

Verzeichnisse suchen
30.09.2013 08:54:06
Zschech
Hallo, einen schönen guten Tag!
Ich möchte das nachfolgende Makro bitte erweitert haben.
Zur Zeit kopiere ich die Datei in ein Verzeichni und das Makroes liest von allen darin befindlichen Excelmappen 25 Zeilen von dem Blatt "D" aus und kopiert sie untereinander in diese Datei. Ich möchte die Datei nicht mehr kopieren, sondern das Makro soll die vier Verzeichnisse, Q:\Daten El\2012; Q:\Daten El\2013; V:\Daten Metall\2012 und V:\Daten Metall\2013 selbständig durchsuchen.
Ich bedanke mich im Vorraus für eure Bemühungen.
Private Sub CommandButton1_Click()
Dim strWB As String
Dim lngRow As Long
lngRow = 3
strWB = Dir(ThisWorkbook.Path & "\*.xls*", vbNormal)
With ThisWorkbook.Sheets("D")
.Range("B3:R" & .Rows.Count) = ""
Do While strWB  ""
If strWB  ThisWorkbook.Name Then
With .Range(.Cells(lngRow, 2), .Cells(lngRow + 24, 142))
.Formula = "='" & ThisWorkbook.Path & "\[" & strWB & "]D'!B4"
.Value = .Value
End With
lngRow = lngRow + 25
End If
strWB = Dir
Loop
End With
End Sub

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Verzeichnisse suchen
30.09.2013 09:21:40
Beverly
Hi,
versuche es mal so (ungetestet):
Sub Kopieren()
ThisWorkbook.Sheets("D").Range("B3:R" & Rows.Count).ClearContents
OrdnerAuswahl "Q:\Daten El\"
OrdnerAuswahl "V:\Daten Metall\"
End Sub
Sub OrdnerAuswahl(varSuchordner)
Dim fso As Object
Dim Ordner
Dim UnterOrdner
Dim strWB As String
Dim lngRow As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = fso.getfolder(varSuchordner)
With ThisWorkbook.Sheets("D")
For Each UnterOrdner In Ordner.subfolders
If InStr(UnterOrdner, 2012) > 0 Or InStr(UnterOrdner, 2013) > 0 Then
strWB = Dir(UnterOrdner & "\*.xls")
Application.ScreenUpdating = False
' Schleife über alle Arbeitsmappen des Unterordners
Do While strWB  ""
If strWB  ThisWorkbook.Name Then
With .Range(.Cells(lngRow, 2), .Cells(lngRow + 24, 142))
.Formula = "='" & ThisWorkbook.Path & "\[" & strWB & "]D'!B4"
.Value = .Value
End With
lngRow = lngRow + 25
End If
Application.DisplayAlerts = False
Workbooks(strWB).Close False
Application.DisplayAlerts = True
strWB = Dir
Loop
End If
Application.ScreenUpdating = True
OrdnerAuswahl UnterOrdner
Next
End With
Set fso = Nothing
Set Ordner = Nothing
End Sub

Anzeige
AW: Verzeichnisse suchen
30.09.2013 10:46:49
Zschech
Danke für die schnelle Antwort. Das ist doch aufwändiger als ich gedacht hatte. Das hätte ich niemals hinbekommen. Ich probier es nachher gleich mal aus und melde mich dann nochmal.

AW: Verzeichnisse suchen
30.09.2013 12:45:45
Zschech
Habe die Verzeichnisse angepasst. Das eine habe ich geremmt weil die Verzeichnisnamen noch nicht ganz stimmen. Das Makro bleibt aber an der Stelle Stop >> stehen.
Private Sub CommandButton1_Click()
ThisWorkbook.Sheets("D").Range("B3:R" & Rows.Count).ClearContents
'OrdnerAuswahl "\\035-sv1\lehrgangsmappen$\RAE"
OrdnerAuswahl "\\035-sv1\lehrgangsmappen$\RAM"
End Sub
Sub OrdnerAuswahl(varSuchordner)
Dim fso As Object
Dim Ordner
Dim UnterOrdner
Dim strWB As String
Dim lngRow As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = fso.getfolder(varSuchordner)
With ThisWorkbook.Sheets("D")
For Each UnterOrdner In Ordner.subfolders
If InStr(UnterOrdner, 2012) > 0 Or InStr(UnterOrdner, 2013) > 0 Then
strWB = Dir(UnterOrdner & "\*.xls")
Application.ScreenUpdating = False
' Schleife über alle Arbeitsmappen des Unterordners
Do While strWB  ""
If strWB  ThisWorkbook.Name Then
Stopp>>        With .Range(.Cells(lngRow, 2), .Cells(lngRow + 24, 142))
.Formula = "='" & ThisWorkbook.Path & "\[" & strWB & "]D'!B4"
.Value = .Value
End With
lngRow = lngRow + 25
End If
Application.DisplayAlerts = False
Workbooks(strWB).Close False
Application.DisplayAlerts = True
strWB = Dir
Loop
End If
Application.ScreenUpdating = True
OrdnerAuswahl UnterOrdner
Next
End With
Set fso = Nothing
Set Ordner = Nothing
End Sub

Anzeige
AW: Verzeichnisse suchen
30.09.2013 13:48:49
EtoPHG
Hallo,
lngRow wird nicht initialisiert. Setze dies Zeile vor das With Konstrukt: 
   lngRow = 1
With ThisWorkbook.Sheets("D")
Gruess Hansueli

AW: Verzeichnisse suchen
30.09.2013 15:50:39
Zschech
Habe den Wert auf 3 gesetzt, weil ich auf dem Blatt auf dem die Daten zusammengeführt werden erst in der dritten Zeile beginnen will. Jetzt stoppt das Makro an einer anderen Stelle (Stop>>). Wenn ich einen Rem- Befehl dafor setze geht was. Es klappt eine Fenster auf, "Eigene Dateien". Ich kann aber keine Datei auswählen. Wenn ich das Fenster schließe werden aber die richtigen Dateien eingelesen. Mit jedem Klick eine.Was nun?
Sub OrdnerAuswahl(varSuchordner)
Dim fso As Object
Dim Ordner
Dim UnterOrdner
Dim strWB As String
Dim lngRow As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = fso.getfolder(varSuchordner)
lngRow = 3
With ThisWorkbook.Sheets("D")
For Each UnterOrdner In Ordner.subfolders
If InStr(UnterOrdner, 2012) > 0 Or InStr(UnterOrdner, 2013) > 0 Then
strWB = Dir(UnterOrdner & "\*.xls")
Application.ScreenUpdating = False
' Schleife über alle Arbeitsmappen des Unterordners
Do While strWB  ""
If strWB  ThisWorkbook.Name Then
With .Range(.Cells(lngRow, 2), .Cells(lngRow + 24, 142))
.Formula = "='" & ThisWorkbook.Path & "\[" & strWB & "]D'!B4"
.Value = .Value
End With
lngRow = lngRow + 25
End If
Application.DisplayAlerts = False
Stop>>       Workbooks(strWB).Close False
Application.DisplayAlerts = True
strWB = Dir
Loop
End If
Application.ScreenUpdating = True
OrdnerAuswahl UnterOrdner
Next
End With
Set fso = Nothing
Set Ordner = Nothing
End Sub

Anzeige
AW: Verzeichnisse suchen
30.09.2013 13:56:53
Beverly
Hi,
sorry, ich hatte aus Versehen die Zeile lngRow = 3 mit gelöscht. deshalb ist sie an dieser Stelle nicht belegt und löst den Fehler aus.

AW: Verzeichnisse suchen
01.10.2013 07:30:59
Zschech
Kein Problem aber wie bekomme ich diese Box weg?

AW: Verzeichnisse suchen
01.10.2013 08:42:39
Beverly
es fehlt noch der Befehl zum Öffnen der Arbeitsmappe - hatte nicht bemerkt, dass der in dem Codeteil, den ich von dir übernommen habe, fehlt
               If strWB  ThisWorkbook.Name Then
Workbooks.Open UnterOrdner & "\" & strWB
With .Range(.Cells(lngRow, 2), .Cells(lngRow + 24, 142))
.Formula = "='" & ThisWorkbook.Path & "\[" & strWB & "]D'!B4"
.Value = .Value
End With
lngRow = lngRow + 25
End If

Anzeige

Links zu Excel-Dialogen

CommandButton

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige