Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
944to948
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
944to948
944to948
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Verz.Auslesen/wert suchen/Kopieren

Verz.Auslesen/wert suchen/Kopieren
30.01.2008 10:48:00
Fabio
Hallo zusammen,
ich hoffe mal darauf, das jemand so lieb ist und mir hier was basteln kann. Ich habe die Forumssuche geqäult, diverses ausprobiert, aber irgendwie passt da nichts wirklich richtig.
Was habe ich:
Ein Verzeichnis (C:\Kindersport\2007)
in diesem Verzeichnis habe ich ca. 150 Excel-Dateien
Was möchte ich:
Eine neue Datei Namens "Übersicht" mit einem Script (?)
Problem:
Excel soll alle *.xls in einem Verzeichnis durchsuchen
Suche in der Spalte "A" nach dem Wort "Kindersport"
und falls vorhanden, kopiere die gesamte Zeile (in der das Wort Kindersport steht)
in die Datei "Übersicht" (bzw. hänge die als neue letze Zeile an)
Durchsuche dann die nächste (etc.etc.)
Vielen lieben Dank für Eure Hilfe!
Fabio

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Verz.Auslesen/wert suchen/Kopieren
30.01.2008 12:03:29
Chris
Servus Fabio,
das müsste so gehen:

Sub Suche()
Dim strDateiname As String, strFirst As String, strDateipfad As String
Dim iDateien As Integer
Dim wks As Worksheet
Dim rFinde As Range, rSuche As Range
Dim lReihe As Long
Application.ScreenUpdating = False
With Application.FileSearch
On Error Resume Next
.NewSearch
.LookIn = "C:\Kindersport\2007" ' Hier kann man den Pfad verändern
.Filename = "*.xls"
If .Execute() > 0 Then
For iDateien = 1 To .FoundFiles.Count
strDateiname = Dir(.FoundFiles(iDateien))
strDateipfad = .FoundFiles(iDateien)
If strDateiname  ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(iDateien)
For Each wks In ActiveWorkbook.Worksheets
Set rFinde = wks.Range("A:A")
Set rSuche = rFinde.Find(what:="Kindersport", LookAt:=xlPart, MatchCase:= _
False)
If Not rSuche Is Nothing Then
strFirst = rSuche.Address
Do
lReihe = rSuche.Row
If ThisWorkbook.Sheets(1).Range("A65536") = "" Then
wks.Range("A" & lReihe).EntireRow.Copy ThisWorkbook.Sheets(1).Range(" _
A65536").End(xlUp).Offset(1, 0)
Else
MsgBox "Das Tabellenblatt ist voll! Es wird abgebrochen!", vbExclamation, _
"Abbruch"
ActiveWorkbook.Close
Exit Sub
End If
Set rSuche = rFinde.FindNext(rSuche)
Loop While Not rSuche Is Nothing And rSuche.Address  strFirst
End If
Set rFinde = Nothing
Set rSuche = Nothing
Next wks
ActiveWorkbook.Close
End If
Next
End If
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub


Das Makro in die Datei die als Übersicht dienen soll. Modul ist egal (Alt+F11 öffnet den Editor).
Aber erst mal im kleinen testen.
Gruß
Chris

Anzeige
Fehlermeldung im Code ?
31.01.2008 09:17:43
Fabio
Hallo!
Vielen Dank für die Info.
Bei folgendem Absatz markiert mit der Editor das "rot" (und meldet beim Start auch einen Fehler) :
If ThisWorkbook.Sheets(1).Range("A65536") = "" Then wks.Range("A" & lReihe).EntireRow.Copy ThisWorkbook.Sheets(1).Range(" _
A65536 ").End(xlUp).Offset(1, 0)"
?
Lieben Dank!
Fabio

AW: Fehlermeldung im Code ?
31.01.2008 13:19:26
Chris
Servus,
das liegt am ZeilenUmbruch.
Du musst den zeilenumbruch entfernen (z.B. Leerzeichen mit Enf entfernen)
Die Zeile muss so aussehen:
wks.Range("A" & lReihe).EntireRow.Copy ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
Dann ist die Zeile auch nicht mehr rot.
Gruß
Chris

Anzeige
Klasse, Danke und "Luxus-Frage"
01.02.2008 12:35:00
Fabio
Hallo Chris,
das VBA funktioniert nun genauso wie ich mir das vorstelle.
Vielen Dank dafür - das erleichtert mir einiges !
Fabio
N.S. Falls Du Zeit/Lust/Interesse hast, kann man mir das Makro vielleicht noch erweitern? (Ich kann so damit arbeiten - aber wenn es nicht zu schwer ist, würde ich mich freuen wenn das noch eingebaut wird) :
Problem:
Excel soll alle *.xls in einem Verzeichnis durchsuchen
Suche in der Spalte "A" nach dem Wort "Kindersport"
und falls vorhanden, kopiere die gesamte Zeile (in der das Wort Kindersport steht)
in die Datei "Übersicht" (bzw. hänge die als neue letze Zeile an)
Das kann ja das VBA. Neu:
und falls vorhanden, kopiere die gesamte Zeile (in der das Wort Kindersport steht)
in die Datei "Übersicht" (bzw. hänge die als neue letze Zeile an)
und kopiere in diesem Fall den Wert aus der Excel-Datei (die mit Kindersport) den Wert der in
im Feld "J2" steht und fügen den in die "neu kopierte Zeile" in der Spalte Y ein.
Danke!
Fabio

Anzeige
AW: Klasse, Danke und "Luxus-Frage"
01.02.2008 14:30:41
Chris
Servus,
hab ich's richtig verstanden?
Du willst aus der Quelldatei den Wert aus J2 in die jeweils neu eingefügte Zeile in Übersicht nach Y kopieren?
Gruß
Chris

Luxus-Frage
01.02.2008 15:06:16
fabiomaro@ananzi.co.za
Hallo Chris,
richtig - genau das hätte ich gerne (der Wert steht in der Quelldatei in der Zelle J2 (als Datum).
Vielleicht wichtig: Quelldatei steht der Wert in J (und J2 und K2 sind eine Zelle!)
Danke
Fabio

AW: Luxus-Frage
01.02.2008 16:14:55
Chris
Servus Fabio,

Sub Suche()
Dim strDateiname As String, strFirst As String, strDateipfad As String
Dim iDateien As Integer
Dim wks As Worksheet
Dim rFinde As Range, rSuche As Range
Dim lReihe As Long, letzte as Long
Application.ScreenUpdating = False
With Application.FileSearch
On Error Resume Next
.NewSearch
.LookIn = "C:\Kindersport\2007" ' Hier kann man den Pfad verändern
.Filename = "*.xls"
If .Execute() > 0 Then
For iDateien = 1 To .FoundFiles.Count
strDateiname = Dir(.FoundFiles(iDateien))
strDateipfad = .FoundFiles(iDateien)
If strDateiname  ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(iDateien)
For Each wks In ActiveWorkbook.Worksheets
Set rFinde = wks.Range("A:A")
Set rSuche = rFinde.Find(what:="Kindersport", LookAt:=xlPart, MatchCase:= _
_
False)
If Not rSuche Is Nothing Then
strFirst = rSuche.Address
Do
lReihe = rSuche.Row
If ThisWorkbook.Sheets(1).Range("A65536") = "" Then
wks.Range("A" & lReihe).EntireRow.Copy ThisWorkbook.Sheets(1).Range( _
" A65536").End(xlUp).Offset(1, 0)
With ThisWorkbook.Sheets(1)
letzte = IIf(IsEmpty(.Cells(Rows.Count, 1)),.Cells(Rows.Count, 1). _
End(xlUp).Row, Rows.Count)
End with
wks.Range("J2").Copy ThisWorkbook.Sheets(1).Range("Y" & letzte)
Else
MsgBox "Das Tabellenblatt ist voll! Es wird abgebrochen!",  _
vbExclamation, _
"Abbruch"
ActiveWorkbook.Close
Exit Sub
End If
Set rSuche = rFinde.FindNext(rSuche)
Loop While Not rSuche Is Nothing And rSuche.Address  strFirst
End If
Set rFinde = Nothing
Set rSuche = Nothing
Next wks
ActiveWorkbook.Close
End If
Next
End If
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub


Das müsste so gehen. Kann aber Probleme geben, weil J2 und K2 verbundene Zellen sind. Die machen oft Schwierigkeiten.
Gruß
Chris

Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige