Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Ordner + Unterordner durchsuchen

Frage Entwicklung VB for Applications

Mitglied: Gimli3311

Gimli3311 (Level 1) - Jetzt verbinden

20.02.2015, aktualisiert 23.02.2015, 883 Aufrufe, 11 Kommentare

Guten Tag Zusammen,

da bei meinem letzten Problem hier super geholfen wurde, wende ich mich wieder an euch.

Was macht das Makro von mir bis jetzt:
- Wählt ein Ordner aus
- Sucht nach Dateinamen des Datentypens xlsx.
- Wenn Daten Gefunden wird ein bestimmter Bereich kopiert.
- in aktuelle xlsx-Datei übertragen
- wiederholt den Vorgang solange bis alle gefunden Daten weg sind

Problem:
Es durchsucht nur den Angegebenen Ordner und keine Unterordner.
Ich hab zwar ein Makro gefunden das auch Unterordner durchsucht aber ich bekomme es einfach nicht zusammen.

Hier der bisherige Code:

01.
 
02.
 
03.
Sub ImportTables() 
04.
 
05.
    'Variabeln werden mit passenden Datentypen gesetzt 
06.
    Dim wsTarget As Worksheet, wb As Workbook, fso As Object, rngOut As Range, f As String 
07.
     
08.
    'Pfad in dem die *.xlsx Dateien liegen wird mit der Funktion fncBrowseForFolder ausgewählt 
09.
    'andere Möglichkeit direkter Pfad angeben= (PATHFILES muss dann CONST gesetzt werden) "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test" 
10.
     
11.
    'Greif auf die Funktion fncBrowseForFolder zu um einen Ordner auszuwählen 
12.
    PATHFILES = fncBrowseForFolder 
13.
    'Inputbox wird erstellt in der das Suchwort eingegeben werden soll 
14.
    strFile = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls") 
15.
     
16.
    'Führt das Makro schneller aus und unterdrückt Meldungen 
17.
    Application.ScreenUpdating = False 
18.
    Application.DisplayAlerts = False 
19.
     
20.
    With ActiveSheet 
21.
        'erste Ausgabezelle in neuer .xlsx-Datei festlegen 
22.
        Set rngOut = .Range("A5") 
23.
        'hole die erste *.xlsx-Datei des Ordners 
24.
        'Wenn nichts gefunden wird bleib f ="" --> While Bedingung ist nicht erfüllt und wird übersprungen 
25.
        f = Dir(PATHFILES & "\" & strFile & ".xlsx") 
26.
        'Loope solange bis alle Dateien verarbeitet wurden 
27.
        Do While f <> "" 
28.
            'öffne Datei 
29.
            Set wb = Workbooks.Open(PATHFILES & "\" & f, ReadOnly:=True) 
30.
            'kopiere den Inhalt der Tabelle in das aktuelle Sheet 
31.
            With wb.Sheets(1) 
32.
                .Range("A29:N" & .Cells(Rows.Count, 4).End(xlUp).Row).Copy rngOut 
33.
             End With 
34.
            'schließe Dokument wieder 
35.
            wb.Close False 
36.
            'Ausgabezelle für den nächsten Import ermitteln 
37.
            Set rngOut = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
38.
            'hole Namen der nächsten Datei 
39.
            f = Dir 
40.
        Loop 
41.
        '----Funktionsaufruf um Leere Spalten zu löschen------------------------------------------------------------------ 
42.
        deleteEmptyCells 
43.
        '------------------------------------------------------------------------ 
44.
         
45.
         
46.
    End With 
47.
    Application.ScreenUpdating = True 
48.
    Application.DisplayAlerts = True 
49.
 
50.
End Sub 
51.
 
52.
' Öffnet das Suchfeld für die Ordnerauswahl 
53.
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String 
54.
  Dim objFlderItem As Object, objShell As Object, objFlder As Object 
55.
   
56.
  Set objShell = CreateObject("Shell.Application") 'Vordefinierter Pfad einstellen zu Testzwecken (Standard--> DefaultPath) 
57.
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test\") 
58.
   
59.
  If objFlder Is Nothing Then GoTo ErrExit 
60.
   
61.
  Set objFlderItem = objFlder.Self 
62.
  fncBrowseForFolder = objFlderItem.Path 
63.
   
64.
ErrExit: 
65.
   
66.
  Set objShell = Nothing 
67.
  Set objFlder = Nothing 
68.
  Set objFlderItem = Nothing 
69.
End Function 
70.
 
71.
 
72.
Function deleteEmptyCells() 
73.
 Dim lngLetzte As Long 
74.
 Dim lngZeile As Long 
75.
  
76.
 ' Bildschirmaktualisierung AUSschalten (Makro läuft schneller, Bildschirm flackert nicht) 
77.
 Application.ScreenUpdating = False 
78.
  
79.
  
80.
 ' Letzte belegte Zelle in Spalte B plus 1 raussuchen und merken 
81.
 lngLetzte = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row + 1, 65536) 
82.
 ' in einer Schleife von dieser Letzten bis Zeile 1 gehen - also von unten nach oben 
83.
      For lngZeile = lngLetzte To 1 Step -1 
84.
    ' Wenn die Zelle in der ensprechenden Zeile in Spalte B leer ist 
85.
        If Cells(lngZeile, 2) = "" Then 
86.
    ' dann lösche die gesamte Zeile 
87.
          Cells(lngZeile, 2).EntireRow.Delete 
88.
    ' Ende der Bedingung 
89.
        End If 
90.
    ' Nächste Zeile mit der Bedingung vergleichen 
91.
      Next 
92.
 ' Bildschirmaktualisierung EINschalten (nicht vergessen) 
93.
 Application.ScreenUpdating = True 
94.
End Function 
95.
 
Und hier der gefundene Makrocode wo das macht wo ich eig. brauche bloß nicht zusammenbekomme:

01.
' ********************************************************************** 
02.
' Modul: Modul1 Typ: Allgemeines Modul 
03.
' ********************************************************************** 
04.
 
05.
Option Explicit 
06.
 
07.
Sub DateienErmitteln() 
08.
  Dim objFiles() As Object, lngRet As Long, lngIndex As Long, lngRow As Long 
09.
  Dim strPath As String, strFile As String 
10.
   
11.
  strPath = fncBrowseForFolder ' DateiPfad wird in die Text-Variable strPath kopiert 
12.
  ' wenn strPath ungleich "" dann wird die Inputbox geöffnet 
13.
  If strPath <> "" Then 
14.
    strFile = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls") 
15.
    ' Wenn strFile ungleich "" dann ist wird die Funktion FileSearchINFO in lngRet geschrieben 
16.
    If strFile <> "" Then 
17.
      lngRet = FileSearchINFO(objFiles, strPath, strFile, True) 
18.
      'lngRet wird die Anzahl der gefundenen Daten gespeichert 
19.
      If lngRet > 0 Then 'wenn Dateiname übereinstimmt gehts weiter 
20.
        'Liefert die letzte Spalte von A zurück + 1 
21.
        lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 
22.
        For lngIndex = 0 To lngRet - 1 
23.
          Cells(lngRow + lngIndex, 1) = strPath 
24.
          Cells(lngRow + lngIndex, 2) = objFiles(lngIndex).Name 
25.
          Cells(lngRow + lngIndex, 3) = objFiles(lngIndex).ParentFolder.Path 
26.
          Cells(lngRow + lngIndex, 4) = objFiles(lngIndex).DateCreated 
27.
        Next 
28.
      End If 
29.
    End If 
30.
  End If 
31.
End Sub 
32.
 
33.
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _ 
34.
    Optional ByVal SubFolders As Boolean = True) As Long 
35.
   
36.
  '# PARAMETERINFO: 
37.
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse 
38.
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt 
39.
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien) 
40.
  '# Beispiele: "*.txt" - Findet alle Textdateien 
41.
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen 
42.
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen) 
43.
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False) 
44.
   
45.
  'Deklarierte Variablen werden erstellt 
46.
  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object 
47.
  Dim intC As Integer, varFiles As Variant 
48.
   
49.
  'Erstellt ein FileSystemObject das der Variablen fobjFSO zugeordnet wird 
50.
  Set fobjFSO = CreateObject("Scripting.FileSystemObject") 
51.
  ' Lädt eine Instanz eines vorhandenen Folder Objekts 
52.
  Set ffsoFolder = fobjFSO.GetFolder(InitialPath) 
53.
   
54.
  ' Bei einem Error springe zu ErrExit 
55.
  On Error GoTo ErrExit 
56.
  ' Typ Long start:1; Zeichen:*; Gesucht:";" ; > 0 dann 
57.
  If InStr(1, FileName, ";") > 0 Then 
58.
    varFiles = Split(FileName, ";") 
59.
  Else 
60.
    'Reserviert speicherplatz für neue Arrayvariable 
61.
    ReDim varFiles(0) 
62.
    'Arrayvariable bekommt "*" 
63.
    varFiles(0) = FileName 
64.
  End If 
65.
  'Leitet For Each ein; Group (ffsoFolder.Files) benötigt man fürs Statement 
66.
  For Each ffsoFile In ffsoFolder.Files 
67.
    'Wenn im Object ffsoFile was drin ist dann gehts zur for schleife 
68.
    If Not ffsoFile Is Nothing Then 
69.
    ' führt die schleife nur 1 mal aus 
70.
      For intC = 0 To UBound(varFiles) 
71.
         
72.
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then 
73.
          If IsArray(Files) Then 
74.
            ReDim Preserve Files(UBound(Files) + 1) 
75.
          Else 
76.
            ReDim Files(0) 
77.
          End If 
78.
          Set Files(UBound(Files)) = ffsoFile 
79.
          Exit For 
80.
        End If 
81.
      Next 
82.
    End If 
83.
  Next 
84.
   
85.
  If SubFolders Then 
86.
    For Each ffsoSubFolder In ffsoFolder.SubFolders 
87.
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders 
88.
    Next 
89.
  End If 
90.
   
91.
  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1 
92.
ErrExit: 
93.
  Set fobjFSO = Nothing 
94.
  Set ffsoFolder = Nothing 
95.
End Function 
96.
 
97.
' Öffnet das Suchfeld für die Ordnerauswahl 
98.
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String 
99.
  Dim objFlderItem As Object, objShell As Object, objFlder As Object 
100.
   
101.
  Set objShell = CreateObject("Shell.Application") 
102.
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath) 
103.
   
104.
  If objFlder Is Nothing Then GoTo ErrExit 
105.
   
106.
  Set objFlderItem = objFlder.Self 
107.
  fncBrowseForFolder = objFlderItem.Path 
108.
   
109.
ErrExit: 
110.
   
111.
  Set objShell = Nothing 
112.
  Set objFlder = Nothing 
113.
  Set objFlderItem = Nothing 
114.
End Function 
115.
 



Schon Mal Danke für eure Hilfe
Mitglied: 114757
LÖSUNG 20.02.2015, aktualisiert 23.02.2015
01.
Option Compare Text 'benötigt für einen 'like' Vergleich 
02.
Dim fso As Object 'Variable bitte ganz am Anfang des Codefensters stehen lassen ! 
03.
 
04.
Sub ImportTables() 
05.
 
06.
    'Variabeln werden mit passenden Datentypen gesetzt 
07.
    Dim wb As Workbook, rngOut As Range,f as Variant, objFoundFiles As New Collection, strFileFilter as String 
08.
     
09.
    'FilesystemObject erstellen 
10.
    Set fso = CreateObject("Scripting.Filesystemobject") 
11.
     
12.
    'Pfad in dem die *.xlsx Dateien liegen wird mit der Funktion fncBrowseForFolder ausgewählt 
13.
    'andere Möglichkeit direkter Pfad angeben= (PATHFILES muss dann CONST gesetzt werden) "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test" 
14.
     
15.
    'Greif auf die Funktion fncBrowseForFolder zu um einen Ordner auszuwählen 
16.
    PATHFILES = fncBrowseForFolder 
17.
    'Inputbox wird erstellt in der das Suchwort eingegeben werden soll 
18.
    strFileFilter = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_* (ohne Datei-Erweiterung, es werden nur *.xlsx, *.xlsm und *.xls Dateien gesucht)") 
19.
     
20.
    'Suche Dateien mit passenden Namen 
21.
    enumFiles fso.GetFolder(PATHFILES), strFileFilter, objFoundFiles 
22.
 
23.
    'Wenn Dateien gefunden wurden 
24.
    If objFoundFiles.Count > 0 Then 
25.
        'Führt das Makro schneller aus und unterdrückt Meldungen 
26.
        Application.ScreenUpdating = False 
27.
        Application.DisplayAlerts = False 
28.
         
29.
        With ActiveSheet 
30.
            'erste Ausgabezelle in neuer .xlsx-Datei festlegen 
31.
            Set rngOut = .Range("A5") 
32.
            'Für jede gefundene Datei in der Collection 
33.
            For Each f In objFoundFiles 
34.
                'öffne Datei 
35.
                Set wb = Workbooks.Open(f, ReadOnly:=True) 
36.
                'kopiere den Inhalt der Tabelle in das aktuelle Sheet 
37.
                With wb.Sheets(1) 
38.
                    .Range("A29:N" & .Cells(Rows.Count, 4).End(xlUp).Row).Copy rngOut 
39.
                 End With 
40.
                'schließe Dokument wieder 
41.
                wb.Close False 
42.
                'Ausgabezelle für den nächsten Import ermitteln 
43.
                Set rngOut = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
44.
            Next 
45.
            '----Funktionsaufruf um Leere Spalten zu löschen------------------------------------------------------------------ 
46.
            deleteEmptyCells 
47.
            '------------------------------------------------------------------------ 
48.
        End With 
49.
        Application.ScreenUpdating = True 
50.
        Application.DisplayAlerts = True 
51.
    End If 
52.
End Sub 
53.
 
54.
' Öffnet das Suchfeld für die Ordnerauswahl 
55.
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String 
56.
  Dim objFlderItem As Object, objShell As Object, objFlder As Object 
57.
   
58.
  Set objShell = CreateObject("Shell.Application") 'Vordefinierter Pfad einstellen zu Testzwecken (Standard--> DefaultPath) 
59.
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test\") 
60.
   
61.
  If objFlder Is Nothing Then GoTo ErrExit 
62.
   
63.
  Set objFlderItem = objFlder.Self 
64.
  fncBrowseForFolder = objFlderItem.Path 
65.
   
66.
ErrExit: 
67.
   
68.
  Set objShell = Nothing 
69.
  Set objFlder = Nothing 
70.
  Set objFlderItem = Nothing 
71.
End Function 
72.
 
73.
 
74.
Function deleteEmptyCells() 
75.
 Dim lngLetzte As Long 
76.
 Dim lngZeile As Long 
77.
  
78.
 ' Bildschirmaktualisierung AUSschalten (Makro läuft schneller, Bildschirm flackert nicht) 
79.
 Application.ScreenUpdating = False 
80.
  
81.
  
82.
 ' Letzte belegte Zelle in Spalte B plus 1 raussuchen und merken 
83.
 lngLetzte = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row + 1, 65536) 
84.
 ' in einer Schleife von dieser Letzten bis Zeile 1 gehen - also von unten nach oben 
85.
      For lngZeile = lngLetzte To 1 Step -1 
86.
    ' Wenn die Zelle in der ensprechenden Zeile in Spalte B leer ist 
87.
        If Cells(lngZeile, 2) = "" Then 
88.
    ' dann lösche die gesamte Zeile 
89.
          Cells(lngZeile, 2).EntireRow.Delete 
90.
    ' Ende der Bedingung 
91.
        End If 
92.
    ' Nächste Zeile mit der Bedingung vergleichen 
93.
      Next 
94.
 ' Bildschirmaktualisierung EINschalten (nicht vergessen) 
95.
 Application.ScreenUpdating = True 
96.
End Function 
97.
 
98.
'Funktion um Dateien rekursiv zu suchen 
99.
Sub enumFiles(ByVal rootFolder As Object, ByVal strFilter As String, ByRef col As Collection) 
100.
    On Error Resume Next 
101.
    For Each file In rootFolder.Files 
102.
        ext = LCase(fso.GetExtensionName(file.Name)) 
103.
        If fso.GetBasename(file.Name) Like strFilter And (ext = "xlsx" Or ext = "xls" Or ext = "xlsm") Then 
104.
            col.Add file.Path 
105.
        End If 
106.
    Next 
107.
    For Each subfolder In rootFolder.SubFolders 
108.
        enumFiles subfolder, strFilter, col 
109.
    Next 
110.
End Sub
Gruß jodel32
Bitte warten ..
Mitglied: Gimli3311
23.02.2015, aktualisiert um 08:05 Uhr
Hallo jodel32,

Danke für deine Hilfe.
Ich bekomm in Zeile 33 einen Fehler beim Kompilieren:

"Steuervariable für For Each muß vom Typ Variant oder Object sein."

soll ich da jetzt ein anderes Objekt nehmen oder den Typ umwandeln?
Schon mal Danke für deine Hilfe

Gruß Gimli3311

EDIT: Habe in Zeile 7 die Variable f anstatt As String als As Object gesetzt funktioniert leider immer noch nicht. Es wird immer noch nach einem Object verlangt.

EDIT2: Habe f als As Variant festgelegt. Jetzt kommt keine Fehlermeldung aber es kommen auch keine Ergebnisse raus.
Bitte warten ..
Mitglied: 114757
LÖSUNG 23.02.2015, aktualisiert um 11:22 Uhr
Zitat von Gimli3311:
EDIT2: Habe f als As Variant festgelegt.
Yup mein Fehler, ist korrigiert.
Jetzt kommt keine Fehlermeldung aber es kommen auch keine Ergebnisse raus.
Dann hast du den Dateifilter in der Inputbox falsch eingegeben, bitte ohne Dateierweiterung eingeben !
Wer will schon andere Dateien als *.xlsx *.xls *.xlsm mit Excel öffnen ? Die sind fest in der Funktion hinterlegt, kannst du ja bei Bedarf ändern ...

Gruß jodel32
Bitte warten ..
Mitglied: Gimli3311
23.02.2015 um 09:22 Uhr
Zitat von 114757:


Dann hast du den Dateifilter in der Inputbox falsch eingegeben, bitte ohne Dateierweiterung eingeben !
Wer will schon andere Dateien als *.xlsx *.xls *.xlsm mit Excel öffnen ? Die sind fest in der Funktion hinterlegt, kannst du
ja bei Bedarf ändern ...

Meine Eingabe in die Inputbox sie folgendermaßen aus: "*Logbuch*"
Habe aber mit dem Debugger festgestellt das er auch .txt Dateien sucht und diese ausliest.
Nachdem er die letzte Excel-Datei ausgelesen hat, löscht er dann alle kopierten Daten wieder raus.

Gruß Gimli3311
Bitte warten ..
Mitglied: 114757
23.02.2015 um 09:26 Uhr
Zitat von Gimli3311:
Habe aber mit dem Debugger festgestellt das er auch .txt Dateien sucht und diese ausliest.
Nein tut es nicht, sie erscheinen zwar werden aber nicht mit in die Collection übernommen weil die Extension nicht korrekt ist, siehe die letzte Funktion ...
Nachdem er die letzte Excel-Datei ausgelesen hat, löscht er dann alle kopierten Daten wieder raus.
Das ist dein Problem, die Funktion deleteEmptyCells ist nicht auf meinem Mist gewachsen, und hat mich auch nicht interessiert !!
Bitte warten ..
Mitglied: Gimli3311
23.02.2015, aktualisiert um 10:49 Uhr
Hey jodel32,

Wollte dir nicht zu nahe kommen oder dich verärgern bin über jeden deiner Posts sehr Dankbar.
Ich will ja das das Programm läuft und da ich totaler VBA-Neuling bin stell ich mich Wahrscheinlich hin und wieder blöd an :D

Also bin jetzt nochmal mit dem Debugger mit der Schritt für Schritt Funktion drüber:
Habe in dem Durchsuchten Ordner 3 Excel-Dateien drin und eine .txt mit ein paar Links als Inhalt.

Wenn ich die Dateien kopiere sieht es folgendermaßen aus bevor die deleteEmptyCells() Funktion aufgerufen wird:

5c5c65b2931845aff5fabec26cccff9e - Klicke auf das Bild, um es zu vergrößern

Nachdem die deleteEmptyCells() Funktion ausgeführt wurde waren alle kopierten Daten weg. War mein Fehler da es davor eine Leere xlsx.-Datei in dem Ordner Befand. Ich bekomm jetzt die Tabelle die ich brauche und der kopierte Text von der .txt-Datei ist auch weg aber kopiert den Inhalt mit.
Problem ist das es in dem späteren Verzeichnis viele Ordner mit .txt-Dateien gibt die nicht mit kopiert werden sollten zwecks Performance.

Muss der Wert von ext immer auf NULL bzw. Leer sein? der wird doch gefüllt durch das LCase oder?
01.
'Funktion um Dateien rekursiv zu suchen 
02.
 
03.
 
04.
Sub enumFiles(ByVal rootFolder As Object, ByVal strFilter As String, ByRef col As Collection) 
05.
 
06.
    On Error Resume Next 
07.
    For Each file In rootFolder.Files 
08.
        ext = LCase(fso.GetExtensionName(file.Name)) 
09.
        If fso.GetBasename(file.Name) Like strFilter And (ext = "xlsx" Or ext = "xls" Or ext = "xlsm") Then 
10.
            col.Add file.Path 
11.
        End If 
12.
    Next 
13.
    For Each subfolder In rootFolder.SubFolders 
14.
        enumFiles subfolder, strFilter, col 
15.
    Next 
16.
 
17.
End Sub
Schon mal ein dickes Danke Jodel32 ;)

Gruß Gimli3311
Bitte warten ..
Mitglied: 114757
23.02.2015, aktualisiert um 11:04 Uhr
Wenn ext NULL ist dann hast du die fso Variable nicht wie im Code in Zeile 2 kommentiert nicht am Anfang des Codefensters stehen, das ist sehr Wichtig, denn es ist eine Globale(Public) Variable die aus allen Prozeduren ansprechbar sein soll !!!!!
Diese muss vor allen anderen Prozeduren stehen. fso darf auch nicht irgendwo lokal deklariert werden!
Geht damit hier nämlich einwandfrei! Kopiere den Code nochmal ...
Bitte warten ..
Mitglied: Gimli3311
23.02.2015 um 11:08 Uhr
Also die fso Variable steht ganz oben da hab ich nichts verändert, du hast ja hingeschrieben das die da Oben hingehöhrt.

Hier mal der aktuelle Code, aber es hat sich nicht viel verändert zu vorhin:

01.
Option Compare Text 'benötigt für einen 'like' Vergleich 
02.
 
03.
Dim fso As Object 'Variable ganz am Anfang des Codefensters stehen lassen ! 
04.
 
05.
 
06.
Sub ImportTables() 
07.
 
08.
    'Variabeln werden mit passenden Datentypen gesetzt 
09.
    Dim wb As Workbook, fso As Object, rngOut As Range, f As Variant, objFoundFiles As New Collection, strFileFilter As String 
10.
 
11.
    'FilesystemObject erstellen 
12.
     Set fso = CreateObject("Scripting.Filesystemobject") 
13.
 
14.
    'Pfad in dem die *.xlsx Dateien liegen wird mit der Funktion fncBrowseForFolder ausgewählt 
15.
    'andere Möglichkeit direkter Pfad angeben= (PATHFILES muss dann CONST gesetzt werden) "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test" 
16.
 
17.
    'Greif auf die Funktion fncBrowseForFolder zu um einen Ordner auszuwählen 
18.
    PATHFILES = fncBrowseForFolder 
19.
    'Inputbox wird erstellt in der das Suchwort eingegeben werden soll 
20.
    strFileFilter = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_* (ohne Datei-Erweiterung, es werden nur *.xlsx, *.xlsm und *.xls Dateien gesucht)") 
21.
 
22.
 
23.
    'Suche Dateien mit passenden Namen 
24.
 
25.
    enumFiles fso.GetFolder(PATHFILES), strFileFilter, objFoundFiles 
26.
 
27.
    'Wenn Dateien gefunden wurden 
28.
    If objFoundFiles.Count > 0 Then 
29.
        'Führt das Makro schneller aus und unterdrückt Meldungen 
30.
        Application.ScreenUpdating = False 
31.
        Application.DisplayAlerts = False 
32.
 
33.
        With ActiveSheet 
34.
            'erste Ausgabezelle in neuer .xlsx-Datei festlegen 
35.
            Set rngOut = .Range("A5") 
36.
            'Für jede gefundene Datei in der Collection 
37.
            For Each f In objFoundFiles 
38.
                'öffne Datei 
39.
                Set wb = Workbooks.Open(f, ReadOnly:=True) 
40.
                'kopiere den Inhalt der Tabelle in das aktuelle Sheet 
41.
                With wb.Sheets(1) 
42.
                    .Range("A29:N" & .Cells(Rows.Count, 4).End(xlUp).Row).Copy rngOut 
43.
                 End With 
44.
                'schließe Dokument wieder 
45.
                wb.Close False 
46.
                'Ausgabezelle für den nächsten Import ermitteln 
47.
                Set rngOut = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
48.
            Next 
49.
            '----Funktionsaufruf um Leere Spalten zu löschen 
50.
           deleteEmptyCells 
51.
             
52.
        End With 
53.
        Application.ScreenUpdating = True 
54.
        Application.DisplayAlerts = True 
55.
 
56.
    End If 
57.
 
58.
End Sub 
59.
 
60.
' Öffnet das Suchfeld für die Ordnerauswahl 
61.
 
62.
 
63.
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String 
64.
 
65.
  Dim objFlderItem As Object, objShell As Object, objFlder As Object 
66.
 
67.
 
68.
  Set objShell = CreateObject("Shell.Application") 'Vordefinierter Pfad einstellen zu Testzwecken (Standard--> DefaultPath) 
69.
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\") 
70.
 
71.
  If objFlder Is Nothing Then GoTo ErrExit 
72.
 
73.
  Set objFlderItem = objFlder.Self 
74.
  fncBrowseForFolder = objFlderItem.Path 
75.
 
76.
ErrExit: 
77.
  Set objShell = Nothing 
78.
  Set objFlder = Nothing 
79.
  Set objFlderItem = Nothing 
80.
 
81.
End Function 
82.
 
83.
 
84.
Function deleteEmptyCells() 
85.
 
86.
 Dim lngLetzte As Long 
87.
 Dim lngZeile As Long 
88.
 ' Bildschirmaktualisierung AUSschalten (Makro läuft schneller, Bildschirm flackert nicht) 
89.
 Application.ScreenUpdating = False 
90.
 ' Letzte belegte Zelle in Spalte B plus 1 raussuchen und merken 
91.
 lngLetzte = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row + 1, 65536) 
92.
 ' in einer Schleife von dieser Letzten bis Zeile 1 gehen - also von unten nach oben 
93.
      For lngZeile = lngLetzte To 1 Step -1 
94.
    ' Wenn die Zelle in der ensprechenden Zeile in Spalte B leer ist 
95.
        If Cells(lngZeile, 2) = "" Then 
96.
    ' dann lösche die gesamte Zeile 
97.
          Cells(lngZeile, 2).EntireRow.Delete 
98.
    ' Ende der Bedingung 
99.
        End If 
100.
    ' Nächste Zeile mit der Bedingung vergleichen 
101.
      Next 
102.
 ' Bildschirmaktualisierung EINschalten (nicht vergessen) 
103.
 Application.ScreenUpdating = True 
104.
 
105.
 
106.
End Function 
107.
 
108.
'Funktion um Dateien rekursiv zu suchen 
109.
 
110.
 
111.
Sub enumFiles(ByVal rootFolder As Object, ByVal strFilter As String, ByRef col As Collection) 
112.
 
113.
    On Error Resume Next 
114.
    For Each file In rootFolder.Files 
115.
        ext = LCase(fso.GetExtensionName(file.Name)) 
116.
        If fso.GetBasename(file.Name) Like strFilter And (ext = "xlsx" Or ext = "xls" Or ext = "xlsm") Then 
117.
            col.Add file.Path 
118.
        End If 
119.
    Next 
120.
    For Each subfolder In rootFolder.SubFolders 
121.
        enumFiles subfolder, strFilter, col 
122.
    Next 
123.
 
124.
End Sub 
125.
 
126.
 
Bitte warten ..
Mitglied: 114757
LÖSUNG 23.02.2015, aktualisiert um 11:22 Uhr
In Zeile 9 ist sie noch lokal deklariert, die muss weg
Dim wb As Workbook, fso As Object
Bitte warten ..
Mitglied: Gimli3311
23.02.2015 um 11:21 Uhr
Genau daran lags ;)
Viel Dank Jodel32 und tut mir leid das ich deine Nerven strapaziere.
Bitte warten ..
Mitglied: 114757
23.02.2015, aktualisiert um 11:24 Uhr
Zitat von Gimli3311:
Viel Dank Jodel32 und tut mir leid das ich deine Nerven strapaziere.
Nerven ? Die sind schon alle im Urlaub

Bis zum nächsten mal :-P

Gruß jodel
Bitte warten ..
Neuester Wissensbeitrag
Internet

Unbemerkt - Telekom Netzumschaltung! - BNG - Broadband Network Gateway

(3)

Erfahrungsbericht von ashnod zum Thema Internet ...

Heiß diskutierte Inhalte
Switche und Hubs
Trunk für 2xCisco Switch. Wo liegt der Fehler? (15)

Frage von JayyyH zum Thema Switche und Hubs ...

DSL, VDSL
DSL-Signal bewerten (13)

Frage von SarekHL zum Thema DSL, VDSL ...