Supportnet / Forum / Tabellenkalkulation

Tach an alle! Habe folgendendes Problem, welches ich nicht mehr haben möchte: In einem bestimmten Ordner befinden sich Unterordner (ohne weitere Unterordner) mit ExcelDateien. Nun möchte ich die Unterordner, deren Namen variabel sind (Namen ändern sich) nacheinander per makro öffnen und die jeweiligen ExcelDateien bearbeiten (dafür habe ich schon ein makro). Wie muß das Makro aussehen, um die Unterordner nacheinander zu öffnen und wieder zu schließen? Wenn jemand eine Lösung dafür findet - das wäre Klasse! Gruß mckott

Hi - ich bins nochmal,



um mein Problem zu spezifizieren - es ist eigentlich eine Knobelaufgabe und ich weiß nicht, ob es überhaupt geht:


Also - es gibt einen Ordner mit Namen, der rund 30 Unterordner besitzt, deren Namen variieren (ich weiß die Namen noch nicht)

In den Unterordnern befinden sich Excel Dateien unterschiedlichen Namens und keine weiteren Unterordner.

Die Dateien/Mappen/Daten möchte ich zugehörig zu jedem Unterordner in einer neuen Mappe zusammenfassen und unter dem Namen "Liste & Name des Unterordners" im jeweiligen Unterordner speichern und dann nochmals in einem festgelegten Ordner speichern (dessen Namen ich festlegen kann), in dem dann alle entstandenen Listen/Mappen der Unterordner sich befinden sollen. (sprich 2x in verschiedenen Ordnern Speichern)

Zum Zusammenfassen der Mappen hat nighty mir schon ein Makro geschrieben (Dank nochmals!):

Sub liste_erstellen()
Application.DisplayAlerts = False
Dim i, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = "L:\Experimentierordner\Testdateien"
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Next zaehler2
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub

Das Makro funktioniert einwandfrei - nur der Haken bei der Sache ist jetzt -> wie änder ich den Pfad darin ab für das ".LookIn" wo ich doch die Namen der Unterordner nicht weiß, da sie sich ändern?


So sieht's aus.
Ich grüble nun schon Tage über diese Sache.
Und da ich mich erst vor kurzem mit VBA beschäftige, geht mir das nicht so schnell von der Hand (wenn überhaupt...)

Vielleicht ist das ja für jemanden ein Leichtes.

Bin gespannt auf Eure Antworten!

cu
mckott

hi mckott :))

hier eine sehr schoene variante von einem anderen netten user :)))

gruss nighty

Option Explicit
Private Type BrowseInfo
  hwndOwner As Long
  pIDLRoot As Long
  pszDisplayName As Long
  lpszTitle As Long
  ulFlags As Long
  lpfnCallback As Long
  lParam As Long
  iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Sub Einlesen()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim Start As Long

Rem der zu untersuchende pfad

Ordnername = "C:\briefe"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
  Anzdateien = 0
  intVerzeichnistiefe = 0
  Pfad1 = Ordnername
  If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
  ReDim Verzeichnisse(0)
  Verzeichnisse(0) = Pfad1
  Obergrenze = UBound(Verzeichnisse)
  ReDim Dateien(0)
Rekursion:
  For i = Start To Obergrenze
    Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
    intVerzeichnistiefe = intVerzeichnistiefe + 1
    Start = Start + 1
    Obergrenze = UBound(Verzeichnisse)
    If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
    intVerzeichnistiefe = intVerzeichnistiefe - 1
  Next
  Anzordner = Obergrenze + 1
    If Anzordner = 0 Then
      MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
  Else
    
    Rem ausgabe der directorys :)))
    
    For i = 0 To Anzordner - 1
           Cells(i + 1, 1).Value = Verzeichnisse(i)
    Next
  End If
End If
End Sub
Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory)
Do While Name1 <> ""
    If Name1 <> "." And Name1 <> ".." Then
          If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
        Arraygrenze = Arraygrenze + 1
        ReDim Preserve Verzeichnisse(Arraygrenze)
        Verzeichnisse(Arraygrenze) = Pfad & Name1 & "\"
      End If
    End If
    Name1 = Dir
Loop
End Sub

hi mckott :))

schniff ein wenig gross geworden :))

nicht getestet,probier :))

gruss nighty

Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Sub Einlesen()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim Start As Long
Dim zaehler, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range

Rem der zu untersuchende pfad bzw. laufwerk

Ordnername = "C:\briefe"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername
If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0)
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = Start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
Start = Start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
neueordner = Verzeichnisse(i)
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = neueordner
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For zaehler = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(zaehler)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Next zaehler2
Workbooks(2).Close
Next zaehler
End If
End With
Application.DisplayAlerts = True
Next
End If
End If
End Sub
Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory)
Do While Name1 <> ""
If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
Arraygrenze = Arraygrenze + 1
ReDim Preserve Verzeichnisse(Arraygrenze)
Verzeichnisse(Arraygrenze) = Pfad & Name1 & "\"
End If
End If
Name1 = Dir
Loop
End Sub

hi alle :)

wie immer :(

ueber diese zeile

Rem der zu untersuchende pfad bzw. laufwerk

buedde dies noch einfuegen ,hab noch getestet :)

dim neueordner  as string

gruss nighty

hi alle :)

noch schnell eine kurzbeschreibung falls noch andere interesse haben sollten :)

es werden ab dem zielverzeichnis bzw. laufwerk alle directory eingelesen und dessen inhalt auf *.xls abgetastet ,somit alle excel dateien die gefunden werden geoeffnet werden und obige benannte zellen nach dem workbooks(1) kopiert,datei geschlossen und die naechste wenn vorhanden,es erfolgt eine automatische abtastung des directorybaumes wie der anzahl der jeweiligen tabellen :)))

gruss nighty

p.s.
uebrigens eines meiner lieblingsmakros,es ist ein cooler stil des programmierers :))))
hoffentlich hab ich nichts vergessen ?
ausserdem ist es zu heiss heut hier in spandau :)

hi nighty -

hoffe, es ist wieder ein bißchen kühler in spandau?

danke erstmal für deine hilfe!

habe makro ausprobiert - bekomme eine zusammengefaßte liste aller daten der excel dateien der unterordner. das ist schon mal gut.

alles verstehe ich nicht was im macro steht aber es funktioniert...

einige fragen habe ich jedoch noch:

1.) wennn ich im obigen macro, was von dir war? bei dem befehl

.LookIn = "L:\Experimentierordner\Testdateien"
.SearchSubFolders = False

statt False - True mache -> dann komm ich doch auf das gleiche ergebnis wie bei dem letzten macro?! oder nicht?

2.) habe in einer zelle text stehen, der mehr als 255 zeichen hat -> dieser wird nicht kopiert, in der kopierten zelle steht dann: #WERT! -> wie kann ich das umgehen?

3.) das eine liste erstellt wird von allen excel dateien der unterordner ist ja gut aber: - wie kann ich in das macro einfügen, daß folgendes geschieht:

1 ersten unterordner öffnen
2 neue mappe erstellen
3 in der erstellten mappe die daten der excel dateien dieses unterordners zusammenfassen (denke das wird ähnlich obigem macro sein)
4 diese mappe in hiesigem unterordner unter dem namen "liste & namen des unterordners" abspeichern
5 die gleiche mappe in einem festgelegten ordner abspeichern wo dann alle anderen listen der folgenden unterordner auch abgespeichert werden
6 mappe schließen
7 schleife zum zweiten unterordner (bis alle rund 30 unterordner abgearbeitet sind)
8 dann eine liste erstellen wo alle daten der listen der unterordner zusammengefaßt sind (sprich das wäre dann mein testergebnis des makro des programmierers was dir so gut gefällt ;) )

wenn in dem macro was du mir zuletzt gegeben hast die schritte 1 bis 7 (ohne 6) zu integrieren wären - dann ist das auch fein :)


so - ich hoffe du verstehst was ich meine?
und ich hoffe, daß dich das nicht nochmehr zum schwitzen bringt...



was meinst du?

cu
mckott

hi mckott :)

sag mir deine email,ich schick dir dann wenn fertig ist :)

gruss nighty

hi nighty,

habe dir soeben eine mail geschickt und meine mailadresse öffentlich gemacht...

danke dir!

cu
mckott

tach nighty und alle die es lesen,

hast du meine email nicht bekommen oder keine zeit oder einen hitzeschlag erlitten? ;)

hab mir ne rübe gemacht und habe in den code reingebastelt, daß in jedem unterordner eine neue excel mappe/datei mit dem namen des unterordners kreiert wird (das ist alles nur geklaut...)
ABER wie kann ich den code ändern, daß die ausgelesenen tabellen eines unterordners in die zugehörigen kreierten mappen kopiert werden?
UND wie löse ich das wenn-zellenwert-mehr-als-255-zeichen-dann-wird-es-nicht-kopiert-problem?

eine hilfreiche antwort darauf würde mir schon reichen ;)

hat vielleicht noch ein/e fachkundige/fachkundige außer nighty eine lösung parat?

nochmal den aktuellen code:

Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Sub Einlesen()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim Start As Long
Dim zaehler, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range
Dim neueordner As String

Rem der zu untersuchende pfad bzw. laufwerk

Ordnername = "L:\Experimentierordner\Testdateien"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername
If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0)
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = Start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
Start = Start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
neueordner = Verzeichnisse(i)

Rem habe hier den Mappe erstellen Code eingefügt

Dim strFolderName As String
Dim fldVar As Variant
Dim objFSO As Object
Dim objFolder As Object
Dim fname As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(neueordner)Workbooks.Add
fname = neueordner & "Liste " & objFolder.Name & " .xls"
ActiveWorkbook.SaveAs fname

Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = neueordner
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For zaehler = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(zaehler)
ActiveSheet.Unprotect
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Workbooks(1).Sheets(1).Cells(zaehler1, 4) = Workbooks(2).Sheets(1).Cells(zaehler2, 4)
Workbooks(1).Sheets(1).Cells(zaehler1, 5) = Workbooks(2).Sheets(1).Cells(zaehler2, 5)
Next zaehler2
Workbooks(2).Close
Next zaehler
End If
End With
Application.DisplayAlerts = True
Next
End If
End If
End Sub
Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory)
Do While Name1 <> ""
If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
Arraygrenze = Arraygrenze + 1
ReDim Preserve Verzeichnisse(Arraygrenze)
Verzeichnisse(Arraygrenze) = Pfad & Name1 & "\"
End If
End If
Name1 = Dir
Loop
End Sub


so. - und jetzt?

Gruß
mckott

hi mckott :)

bis montag abend spaetestens ist fertig,tut mir leid das diesmal etwas laenger dauert,brauche ruhe dafuer,die mir momentan genommen wird grrrr

gruss nighty

p.s.
allen noch ein schoenes wochenende

schon mal vorweg :)

1.) wennn ich im obigen macro, was von dir war? bei dem befehl

.LookIn = "L:\Experimentierordner\Testdateien"
.SearchSubFolders = False

setzt du hier true ein so ist keine begrenzung der verzeichnistiefe

2.) habe in einer zelle text stehen, der mehr als 255 zeichen hat

waere wohl schoen mehr als 255 zeichen,mach bill gates ein angebot :)

3.)
diese ,deine wuensche,werden umgesetzt

1 ersten unterordner öffnen
2 neue mappe erstellen
3 in der erstellten mappe die daten der excel dateien dieses unterordners zusammenfassen (denke das wird ähnlich obigem macro sein)
4 diese mappe in hiesigem unterordner unter dem namen "liste & namen des unterordners" abspeichern
5 die gleiche mappe in einem festgelegten ordner abspeichern wo dann alle anderen listen der folgenden unterordner auch abgespeichert werden
6 mappe schließen
7 schleife zum zweiten unterordner (bis alle rund 30 unterordner abgearbeitet sind)
8 dann eine liste erstellen wo alle daten der listen der unterordner zusammengefaßt sind (sprich das wäre dann mein testergebnis des makro des programmierers

hi mckott :)

war nicht so leicht :)

die tabelle sollte nur zum starten des makros benutzt werden,da sich der woorkbookNamen staendig aendert.

erklaeren brauch ich ja wohl nix da in obigen alles steht was so gewerkelt wird,ich hoffe du hast nicht so einen lansamen rechner.

gruss nighty

p.s.
an unsere lehrer :)
fremden code umzugestalten ist nicht einfach,daher buedde um nachsicht

Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Sub start()
Rem zusammenfassung
Einlesen

Rem directorys
Einlesen1
End Sub
Sub Einlesen()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim start As Long
Dim zaehler, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range
Dim neueordner, neueordner1
Range("A1:iv65535").Clear
zweite:

Rem zielpfad zusammenfassung

Ordnername = "C:\test\"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername
If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0)
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
start = start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
neueordner = Verzeichnisse(i)
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = neueordner
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For zaehler = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(zaehler)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Next zaehler2
Workbooks(2).Close
Next zaehler
End If
End With
If Len(neueordner) > Len(Ordnername) Then

Rem speicherpfad der zusammenfassung

ActiveWorkbook.SaveAs Filename:="c:\test3\" & "zusammenfassung.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
Next
End If
End If
Application.DisplayAlerts = True
End Sub
Sub Einlesen1()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim start As Long
Dim zaehler, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range
Dim neueordner, neueordner1
Range("A1:iv65535").Clear

Rem zielpfad der zusammenfassung einzelner directorys

Ordnername = "C:\test\"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername
If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0)
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
start = start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
neueordner = Verzeichnisse(i)
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = neueordner
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For zaehler = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(zaehler)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Next zaehler2
Workbooks(2).Close
Next zaehler
End If
End With
If Len(neueordner) > Len(Ordnername) Then
For zaehler1 = Len(neueordner) - 1 To 1 Step -1
If Mid$(neueordner, zaehler1, 1) = "\" Then
neueordner1 = Mid$(neueordner, zaehler1 + 1, Len(neueordner) - zaehler1 - 1)
zaehler1 = 1
End If
Next zaehler1

Rem speicherpfad der zusammenfassung einzelner directorys

ActiveWorkbook.SaveAs Filename:="c:\test3\" & neueordner1 & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
Next
Application.DisplayAlerts = True
End If
End If
End Sub
Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory)
Do While Name1 <> ""
If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
Arraygrenze = Arraygrenze + 1
ReDim Preserve Verzeichnisse(Arraygrenze)
Verzeichnisse(Arraygrenze) = Pfad & Name1 & "\"
End If
End If
Name1 = Dir
Loop
End Sub

hi mckott :)

war nicht so leicht :)

die tabelle sollte nur zum starten des makros benutzt werden,da sich der woorkbookNamen staendig aendert.

erklaeren brauch ich ja wohl nix da in obigen alles steht was so gewerkelt wird,ich hoffe du hast nicht so einen lansamen rechner.

gruss nighty

p.s.
an unsere lehrer :)
fremden code umzugestalten ist nicht einfach,daher buedde um nachsicht

Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Sub start()
Rem zusammenfassung
Einlesen

Rem directorys
Einlesen1
End Sub
Sub Einlesen()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim start As Long
Dim zaehler, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range
Dim neueordner, neueordner1
Range("A1:iv65535").Clear
zweite:

Rem zielpfad zusammenfassung

Ordnername = "C:\test\"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername
If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0)
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
start = start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
neueordner = Verzeichnisse(i)
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = neueordner
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For zaehler = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(zaehler)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Next zaehler2
Workbooks(2).Close
Next zaehler
End If
End With
If Len(neueordner) > Len(Ordnername) Then

Rem speicherpfad der zusammenfassung

ActiveWorkbook.SaveAs Filename:="c:\test3\" & "zusammenfassung.xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
Next
End If
End If
Application.DisplayAlerts = True
End Sub
Sub Einlesen1()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 5
Dim intVerzeichnistiefe As Integer
Dim start As Long
Dim zaehler, zaehler1, zaehler2, a, alta, lzeile, lspalte
Dim lastcell As Range
Dim neueordner, neueordner1
Range("A1:iv65535").Clear

Rem zielpfad der zusammenfassung einzelner directorys

Ordnername = "C:\test\"
If Ordnername = False Then Exit Sub
ChDir Ordnername
ChDir ".."
If Ordnername <> "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername
If Right(Ordnername, 1) <> "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0)
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
start = start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe < cVerzeichnistiefe Then GoTo Rekursion
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
neueordner = Verzeichnisse(i)
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = neueordner
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For zaehler = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(zaehler)
Set lastcell = ActiveSheet.Cells.SpecialCells(xlLastCell)
alta = lastcell.Row
a = lastcell.Row
Do While Application.CountA(Rows(a)) = 0 And a <> 1
a = a - 1
Loop
alta = a
lzeile = alta
For zaehler2 = 1 To lzeile
zaehler1 = zaehler1 + 1
Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)
Next zaehler2
Workbooks(2).Close
Next zaehler
End If
End With
If Len(neueordner) > Len(Ordnername) Then
For zaehler1 = Len(neueordner) - 1 To 1 Step -1
If Mid$(neueordner, zaehler1, 1) = "\" Then
neueordner1 = Mid$(neueordner, zaehler1 + 1, Len(neueordner) - zaehler1 - 1)
zaehler1 = 1
End If
Next zaehler1

Rem speicherpfad der zusammenfassung einzelner directorys

ActiveWorkbook.SaveAs Filename:="c:\test3\" & neueordner1 & ".xls", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
Next
Application.DisplayAlerts = True
End If
End If
End Sub
Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory)
Do While Name1 <> ""
If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
Arraygrenze = Arraygrenze + 1
ReDim Preserve Verzeichnisse(Arraygrenze)
Verzeichnisse(Arraygrenze) = Pfad & Name1 & "\"
End If
End If
Name1 = Dir
Loop
End Sub

hi alle :)

telekom war abgestuerzt,jetzt ist er zweimal da :(
gruss nighty

hi mckott :)

diese ist der start,nicht das uebersehen wird :)

Sub start()
Rem zusammenfassung
Einlesen
Rem directorys
Einlesen1
End Sub

gruss nighty

...respect.

genau so wie ich es haben wollte. :)
es hat mich fast erschlagen als ich das viele blau sah...
hab alles ausprobiert - und es haut!

danke dir nighty!


ABER noch was ... mich beschäftigt das problem mit dem 255er limit- das muß doch gehen! ich lass nicht locker.

habe gelesen, daß es möglich ist, den inhalt einer steuerelement textbox zu kopieren und die textbox kann auf alle fälle mehr als 255 zeichen enthalten und es hört hinter dem 255sten zeichen nicht mehr auf nach dem kopieren - stimmt das?

wenn ja dann mal angenommen:

in den auszulesenden/zusammenzufassenden excel dateien (die ja alle gleich in der struktur sind) ist jeweils eine steuerelement textbox mit der der, ich sag einfach mal, zelle B6 verknüft.

ist es möglich die inhalte der textboxen aller excel dateien/mappen in einem blatt in die zellen der spalte A untereinander einzulesen/oder auszulesen?

wenn ja - läßt sich das auch nach obigem system (sprich pro unterordner eine zusammenfassung desselben und eine zusammenfassung für alle) umsetzen?

...da raucht der kopf schon wieder...




gruß

mckott

ich nochmal...

wo hab ich die info her?

http://xlfaq.herber.de/

zitat anfang:

Gründe für den Einsatz von TextBoxes:

- Es muss damit gerechnet werden, dass das Tabellenblatt kopiert wird. Beim Kopieren von Arbeitsblättern gehen Zellinhalte, die über 255 Zeichen hinausgehen, verloren. Dieser Effekt tritt bei TextBoxes - egal welcher Art sie sind - nicht auf.

- Der TextBoxes soll ein Makro zugewiesen werden, dass beim TextBox-Klick gestartet wird. In diesem Fall ist eine TextBox aus der Zeichnen-Symbolleiste einzusetzen.

- Die TextBox soll auf Ereignisse reagieren; beispielsweise soll nur die Eingabe von Ganzzahlen zulässig sein. In diesem Fall ist eine TextBox aus der Steuerelement-ToolBox einzusetzen.

Zeichenbegrenzungen in TextBoxes:

Arbeitsblatt LongText

Es gibt versionsabhängige Beschränkungen der Anzahl der Zeichen in TextBoxes, die jedoch in der Praxis keine Rolle spielen, da die Elemente mehr Zeichen aufnehmen können, als auf einer Seite bei normalem Zoom darstellbar sind.

Während die Daten einer Steuerelement-TextBox über VBA ohne Beschränkung ein- und ausgelesen werden können, gibt es bei der Zeichnen-TextBox eine Limitation von 255 Zeichen, die allerdings wie folgt umgangen werden kann:
Einlesen in die TextBox
Der Code ist nur in der Vollversion verfügbar

Hier können Sie das Tutorial bestellen
Auslesen aus der TextBox
Der Code ist nur in der Vollversion verfügbar

Hier können Sie das Tutorial bestellen

zitat ende.

ich möchte kein tutorial bestellen weil mich die zeichnen-textbox nicht interessiert.

und zum kopieren von der steuerelement-textbox habe ich keine ahnung und auch sonst im web nichts (für mich) brauchbares gefunden...

cu
mckott

hi mckott :)

dies ueber textboxen zu gestalten ist auch recht umfangreich,zudem ich damit noch nie gearbeitet habe,daher muss ich leider passen.

vielleicht haben ja andere user noch ideen

gruss nighty

hi nighty!

weißt du warum ich mich mit dem gedanken der textbox verrannt habe?

habe mich noch beim herberforum erkundigt und bekam die erkenntnis, dass hinter

Workbooks(1).Sheets(1).Cells(zaehler1, 1) = Workbooks(2).Sheets(1).Cells(zaehler2, 1)
Workbooks(1).Sheets(1).Cells(zaehler1, 2) = Workbooks(2).Sheets(1).Cells(zaehler2, 2)
Workbooks(1).Sheets(1).Cells(zaehler1, 3) = Workbooks(2).Sheets(1).Cells(zaehler2, 3)

ein .value fehlt...........

und wenn das dann so aussieht:

Workbooks(1).Sheets(1).Cells(zaehler1, 1).Value = Workbooks(2).Sheets(1).Cells(zaehler2, 1).Value
Workbooks(1).Sheets(1).Cells(zaehler1, 2).Value = Workbooks(2).Sheets(1).Cells(zaehler2, 2).Value
Workbooks(1).Sheets(1).Cells(zaehler1, 3).Value = Workbooks(2).Sheets(1).Cells(zaehler2, 3).Value

----> dann wird auch alles kopiert und die zeichen nicht hinter dem 255sten abgeschnitten!

...und die ganze sache mit der steuerbox hat sich erledigt.

gruß
mckott

hi mckott :)

soweit ich weiss ist dies eigentlich nur fuer excel 95 zwingend :)

hast du etwa dieses MUSEUMSTUECK :)))

na dann hast du ja glueck,viel spass dann noch :))

gruss nighty

hi nighty,

excel 2000 zwingt dich und mich zu solchen aktionen...

dir auch noch viel spaß!

cu
mckott

hi mckott :)

gut zu wissen,moechtest du nicht meine ca. 230 makros umschreiben grrrr,also wieder was gelernt,demnaechst alle mit value :))))

gruss nighty

• Datei über Makro öffnen & Werte aus geöffneter Datei kopieren
• Makro zum Öffnen einer bestimmten Arbeitsmappe
• makro um beim öffnen der Arbeitsmappe dateiname zu prüfen
• geschützte excel datei mit makro öffnen