Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
964to968
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
964to968
964to968
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

SUCHFUNKTION

SUCHFUNKTION
29.03.2008 08:33:00
TopDog
Hallo da draussen...
Ich muss bei mir auf der Arbeit Excelsheets umarbeiten. Da es ne ganze Menge an Sheets (ca. 100) sind und es Tage dauern wird suche ich folgendes:
Eine Funktion, die mir alle Bezeichnungen aus Spalte D ab Zeile 9 ind den Sheets raussucht, ohne doppelte, in ein Excelsheet den Dateinamen einträgt
Also so in etwa:
Bezeichnung 1
- Werkzeugliste 1.xls
- Werkzeugliste 9.xls
- Werkzeugliste 15.xls
Bezeichnung 2
- Werkzeugliste 9.xls
- Werkzeugliste 11.xls
usw.
Klar könnte ich dies über die Windows Suchfunktion lösen aber dazu müsste ich ein Sheet öffen, eine Bezeichnung raussuchen, in die Suchfunktion eingeben, mit Hand die gefundenen rausschreiben, die nächste Bezeichnung suchen... usw. Allerdings wäre nicht gewährleistet, das ich auch wirklich alle Bezeichnungen gesucht habe.
Die Sheets liegen alle in dem gleichen Ordner (C:\WZL\)
Gibt es hierfür Lösungsmöglichkeiten?
Hier mal eine Liste wie diese aussehen:
https://www.herber.de/bbs/user/51125.xls
LG Topdog

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: SUCHFUNKTION
29.03.2008 11:54:01
Erich
Hallo TopDog (Was für ein Name...),
probier mal:

Option Explicit
Sub Bez_Liste()
Dim strM As String, lngQ As Long, lngZ As Long, wkZ As Worksheet
Const strV = "C:\WZL\"                    ' Quellverzeichnis
Set wkZ = Worksheets.Add(before:=Sheets(1))
With Range("A1:B1")
.Value = Split("Bezeichnung Datei")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
lngZ = 2
strM = Dir(strV & "*.xls")
Do While strM  ""
Workbooks.Open strV & strM, False, True
With Worksheets(1)
lngQ = .Cells(.Rows.Count, 4).End(xlUp).Row
Range(wkZ.Cells(lngZ, 1), wkZ.Cells(lngZ + lngQ - 9, 1)).Value = _
Range(.Cells(9, 4), .Cells(lngQ, 4)).Value
Range(wkZ.Cells(lngZ, 2), wkZ.Cells(lngZ + lngQ - 9, 2)).Value = strM
End With
ActiveWorkbook.Close False
lngZ = lngZ + lngQ - 8
strM = Dir()
Loop
Range("A1:B" & lngZ - 1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("D1"), Unique:=True
Columns("A:C").Delete
Cells(1, 1).Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns("A:C").AutoFit
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: SUCHFUNKTION
29.03.2008 12:59:02
TopDog
Genial!!! Danke Erich!!!
Was hast du gegen meinen Namen *lach* is doch nett :)
Funktioniert soweit... Jetzt versuche ich mal selbst ob ich diese Dateinamen auch gleich als Hyperlink umwandeln kann...
LG

AW: SUCHFUNKTION
29.03.2008 12:41:00
Daniel
Hi
das geht relativ einfach:
Sub Test()
Dim Pfad As String
Dim Datei As String
Dim Texte
Dim shZiel As Worksheet
Dim i As Long, Zeile As Long
Set shZiel = ThisWorkbook.Sheets(1)
Pfad = "C:\WZL\"
Datei = Dir(Pfad & "*.xls")
Do Until Datei = ""
'--- Datei öffnen, Bezeichungen in Array kopiern und Datei schließen
Workbooks.Open Pfad & Datei, , True
Texte = Range(Cells(7, 4), Cells(Rows.Count, 4).End(xlUp)).Value
ActiveWorkbook.Close False
'--- Prüfen, ob Bezeichungen in der Datei vorhanden sind
If UBound(Texte, 1) > 2 Then
For i = 3 To UBound(Texte, 1)
If Texte(i, 1) "" Then
'--- Bezeichnung in Liste suchen und ggf Ergänzen
If WorksheetFunction.CountIf(shZiel.Columns(1), Texte(i, 1)) = 0 Then
shZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Texte(i, 1)
End If
'--- Datei der Bezeichnung in Liste eintragen (ohne doppelte)
Zeile = WorksheetFunction.Match(Texte(i, 1), shZiel.Columns(1), 0)
If WorksheetFunction.CountIf(shZiel.Rows(Zeile), Datei) = 0 Then
shZiel.Cells(Zeile, 256).End(xlToLeft).Offset(0, 1).Value = Datei
End If
End If
Next
End If
'--- nächste Datei suchen
Datei = Dir()
Loop
End Sub
in dem Verzeichnis sollten aber nur solche Listen stehen und keine andern Excel-Dateien (auch in Unterverzeichnissen)
die Liste wird nach folgendem Schema erstellt:

Bezeichnung1  Datei1  Datei2  Datei4
Bezeichnung2  Datei1  Datei4  Datei5  Datei7
Bezeichnung3  Datei3  Datei5


Gruß, Daniel

Anzeige
AW: SUCHFUNKTION
29.03.2008 12:43:00
Daniel
Hi
das geht relativ einfach:

Sub Test()
Dim Pfad As String
Dim Datei As String
Dim Texte
Dim shZiel As Worksheet
Dim i As Long, Zeile As Long
Set shZiel = ThisWorkbook.Sheets(1)
Pfad = "C:\WZL\"
Datei = Dir(Pfad & "*.xls")
Do Until Datei = ""
'--- Datei öffnen, Bezeichungen in Array kopiern und Datei schließen
Workbooks.Open Pfad & Datei, , True
Texte = Range(Cells(7, 4), Cells(Rows.Count, 4).End(xlUp)).Value
ActiveWorkbook.Close False
'--- Prüfen, ob Bezeichungen in der Datei vorhanden sind
If UBound(Texte, 1) > 2 Then
For i = 3 To UBound(Texte, 1)
If Texte(i, 1)  "" Then
'--- Bezeichnung in Liste suchen und ggf Ergänzen
If WorksheetFunction.CountIf(shZiel.Columns(1), Texte(i, 1)) = 0 Then
shZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Texte(i, 1)
End If
'--- Datei der Bezeichnung in Liste eintragen (ohne doppelte)
Zeile = WorksheetFunction.Match(Texte(i, 1), shZiel.Columns(1), 0)
If WorksheetFunction.CountIf(shZiel.Rows(Zeile), Datei) = 0 Then
shZiel.Cells(Zeile, 256).End(xlToLeft).Offset(0, 1).Value = Datei
End If
End If
Next
End If
'--- nächste Datei suchen
Datei = Dir()
Loop
End Sub


in dem Verzeichnis sollten aber nur solche Listen stehen und keine andern Excel-Dateien (auch in Unterverzeichnissen)
die Liste wird nach folgendem Schema erstellt:


Bezeichnung1  Datei1  Datei2  Datei4
Bezeichnung2  Datei1  Datei4  Datei5  Datei7
Bezeichnung3  Datei3  Datei5


Gruß, Daniel

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige