suchen in ordnern + rauskopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: suchen in ordnern + rauskopieren von: Taz
Geschrieben am: 25.02.2005 18:27:31

Hallo Leute,

an die VBA Spezialisten,
habe da ein ein VBA Problem, an dem ich so langsam verzweifle.
Vielleicht könnt ihr mir ja helfen.

Problembeschreibung:
Excel 2003

1x Exceldatei: 1453 Seriennummer von A1 bis A1453 in Tabelle1

Diese Seriennummern müssen
-rausgesucht
-umkopiert werden

rausgesucht AUS: Ordner, mit dem Namen -Seriennummern- (IN dem Ordner befinden sich 434 Excel-Dateien)

folgende Struktur von einer der 434 Dateien

Blatt 1: Blattname-Übersicht- wichtig ist Zelle B3 dort steht die SENDUNGSNUMMER
Blatt 2 O D E R Blatt 3 (ist unterschiedlich !!!): Blattname-Monitor- dort fangen IMMER ab Zelle B5 gesuchten Seriennummern an.

Eine Seriennummer sieht wie folgt aus CEK888129 ... usw. die ersten 9 Zeichen sind IMMER gleich.

Nun muss ich die 1453 Seriennummer (siehe Info oben) aus dem Ordner -Seriennummern- (mit den 434 Excel-Dateien)raussuchen lassen

FALLS eine Seriennummer aus den 1453 ÜBEREINSTIMMT mit einer Seriennummer aus dem ORDNER "Seriennummern" dann soll diese gefundene, Seriennummer in ein NEUES Tabellenblatt kopiert werden und die ZUGEHÖRIGE SENDUNGSNUMMER (Sendungsnummer befindet sich IMMER auf Blatt1: "Übersicht" Zelle B3, der jeweiligen Excel-Datei) soll neben die gefundene Seriennummer eingefügt werden ... so dass man auch weiss, zu welcher Sendung die gefundene, übereinstimmende Seriennummer gehört.

Wäre klasse wenn ihr mir da helfen könntet. Habe schon stundenlang mit dem Macrorecorder selber dran gebastelt und versucht dann mit dem VBA-Editor das Makro dann anzupassen ... aber das klappt nicht wirklich / kommt nur Schwachsinn heraus.

Gruss
Taz

Bild


Betrifft: AW: suchen in ordnern + rauskopieren von: Josef Ehrensberger
Geschrieben am: 25.02.2005 18:56:50

Hallo Taz!

Ist die Suche mit dem finden einer Seriennummer abgeschlossen, oder
muss immer in allen 434 Dateien gesucht werden, weil Seriennummern
mehrfach vorkommen können?


Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: suchen in ordnern + rauskopieren von: Dave
Geschrieben am: 25.02.2005 19:06:33

Hi,

wie wird denn da festgestellt, ob die Maus bewegt wurde, kann nichts erkennen?

Gruß Dave


Bild


Betrifft: AW: suchen in ordnern + rauskopieren von: Taz
Geschrieben am: 25.02.2005 19:10:52

Hallo Sepp!

die Seriennummern kommen in den 434 Dateien jeweils nur 1x vor / keine Duplikate.
Die 1453 Seriennummern (Suchquelle quasi) sollen in den 434 Excel-Dateien (im Ordner Seriennummern) gesucht/gefunden werden. Da kommen keine neuen Dateien / Seriennummern dazu.
Die Suche sollte nicht schon nach einer gefundenen Datei enden ... sondern erst wenn der Suchalgorithmus (Vba-Prozedur) versucht hat, alle 1453 Seriennummern in den 434 Excel-Dateien zu finden und diese mit der jeweiligen gefundenen SrNr die Sendungsnummer mit rauskopiert hat.

Hilfe auch gerne auf email: tazvbaproblem@gmx.de

Gruss
Taz


Bild


Betrifft: AW: suchen in ordnern + rauskopieren von: Josef Ehrensberger
Geschrieben am: 25.02.2005 20:09:56

Hallo Taz!

Hab jetzt keine Zeit zum ausführlichen Testen!

Probier mal diesen Code.



      
Option Explicit

Sub SeekSerialNumbers()
Dim fs As FileSearch
Dim rng As Range, Bereich As Range
Dim actSheet As Worksheet, newSheet As Worksheet
Dim sPath As String, strForm As String, strForm2 As String, _
                        strfile 
As String, strName As String
Dim lFile As Long, lRow As Long

Set actSheet = ThisWorkbook.Sheets("Tabelle1")
Set Bereich = actSheet.Range("A1:A1453")
Set newSheet = ThisWorkbook.Worksheets.Add(after:=actSheet)

newSheet.Name = 
"Neu"

Set fs = Application.FileSearch

On Error GoTo ERRORHANDLER
Application.ScreenUpdating = 
False

sPath = 
"D:\Temp\SN" 'Pfad zum Ordner mit den Seriennummern - anpassen

   
With fs
   .NewSearch
   .LookIn = sPath
   .SearchSubFolders = 
False
   .FileType = msoFileTypeExcelWorkbooks
   .Execute
   
      
For lFile = 1 To .FoundFiles.Count
      
      strName = Right(.FoundFiles(lFile), InStr(1, StrReverse(.FoundFiles(lFile)), 
"\") - 1)
      strfile = 
"'" & sPath & "\[" & strName & "]Monitor'!$B:$B,0)"
      
         
For Each rng In Bereich
         
         strForm = 
"=MATCH(" & actSheet.Name & "!" & rng.Address & "," & strfile
         strForm2 = 
"='" & sPath & "\[" & strName & "]Übersicht'!$B3"
         
         newSheet.Cells(65536, 1).Formula = strForm
         
            
If IsNumeric(newSheet.Cells(65536, 1)) Then
            lRow = lRow + 1
            newSheet.Cells(lRow, 1) = rng.Value
            newSheet.Cells(lRow, 2) = strForm2
            newSheet.Cells(lRow, 2) = newSheet.Cells(lRow, 2).Value
            
Exit For
            
End If
         
         
Next
      
      
Next
   
   
End With
   
ERRORHANDLER
Application.ScreenUpdating = 
True
   
newSheet.Cells(65536, 1).ClearContents

End Sub 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: kleine korrektur! von: Josef Ehrensberger
Geschrieben am: 25.02.2005 21:01:26

Hallo Taz!

Im Code fehlt in der drittletzten Zeile der Doppelpunkt.


ERRORHANDLER:
Application.ScreenUpdating = True

Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: kleine korrektur! von: Taz
Geschrieben am: 25.02.2005 21:40:49

Hi Sepp!

teste gerade ... rechner ist ziemlich ausgelastet ... denke mal, das ist ein gutes anzeichen ... hab den doppelpkt eingefügt, jetzt fkts

bin mal auf das ergebnis gespannt, und wie lange der noch brauchen wird


gruss
Taz


Bild


Betrifft: AW: kleine korrektur! von: Taz
Geschrieben am: 26.02.2005 17:59:24

Hi Sepp!

hat ziemlich lange gedauert / aber der hat nur 63 Stück gefunden.
Hab mal manuell nach einer SrNr gesucht, und diese wurde vom VBA Skript nicht gefunden, obwohl Sie da ist.

Es sieht so aus, als wenn er eine Übereinstimmung (eine SrNr gefunden z.b.) hat, er in der Datei nicht mehr nach anderen Übereinstimmungen sucht.

Wäre klasse, wenn wir das Problem auch noch irgendwie lösen könnten, da der Ansatz ja schon super klappt.

Gruss
Taz


Bild


Betrifft: AW: kleine korrektur! von: Josef Ehrensberger
Geschrieben am: 27.02.2005 00:00:27

Hallo Taz!

Da hab ich dich falsch verstanden!
Ich hab den Code jetzt umgestellt, so das immer alle Nummern in allen
Dateien gesucht werden!

Wird aber natürlich noch länger dauern, es sind immerhin über 630.000
Vergleiche die gemacht werden müssen.

Um das ganze ein wenig zu beschleunigen lese ich jetzt den Bereich mit den
Seriennummern in Tabelle1 in ein Array ein. Weiters werden die Files nicht
mehr per FileSearch ermittelt, sondern mttels "FileSystemObject".

Und um das ganze noch ein wenig schneller zu machen, werden gefundene Seriennummern
aus dem Array entfernt, weil sie ja sowieso nicht mehr gefunden werden!

Um wenigstens zu wissen, das der Code arbeitet, wird in der Statuszeile
eine Info über den bisherigen Verlauf der Suche angezeigt!

Hier der Code.


      
Option Explicit

Sub SucheInGeschlossenenDateienMitFSO()
'by - j.ehrensberger
'Die Suchbegriffe (Tabelle1 - A1:A1453) werden in allen
'Exceldateien (Tabelle "Monitor") eines Verzeichnisses gesucht (mittels Formel)!
'Bei positivem Formelergebnis wird aus einem anderen Blatt (Übersicht)
'der Datei, ein Wert ausgelesen und mit dem Suchbegriff
'in ein neues Tabellenblatt geschrieben.
'Die Dateinamen werden mit Hilfe des "FileSystemObject" ausgelesen

Dim fso, fo, fF, foF
Dim Bereich As Variant
Dim actSheet As Worksheet, newSheet As Worksheet
Dim sPath As String, strForm As String, strForm2 As String, strfile As String
Dim lRow As Long, n As Integer, i As Integer


On Error GoTo ERRORHANDLER
Application.ScreenUpdating = 
False

Set actSheet = ThisWorkbook.Sheets("Tabelle1")

Bereich = actSheet.Range(
"A1:A1453").Value

Set newSheet = ThisWorkbook.Worksheets.Add(after:=actSheet)

newSheet.Name = 
"Neu"


sPath = 
"D:\Temp\SN" 'Pfad zum Ordner mit den Seriennummern - anpassen

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

   
Set fso = CreateObject("Scripting.FileSystemObject")
   
Set fo = fso.GetFolder(sPath)
   
Set foF = fo.Files
   
      
For Each fF In foF
      i = i + 1
         
If fso.GetExtensionName(fF) = "xls" Then
         
         Application.StatusBar = 
"Durchsuche Datei: """ & fF.Name & _
         
""" ( " & i & " von " & foF.Count & " ) ; Insgesamt gefunden: " & lRow
         
         strfile = 
"'" & sPath & "[" & fF.Name & "]Monitor'!$B:$B,0)"
         
            
For n = 1 To UBound(Bereich, 1)
            
If Bereich(n, 1) <> "" Then
            strForm = 
"=MATCH(""" & Bereich(n, 1) & """," & strfile
            strForm2 = 
"='" & sPath & "[" & fF.Name & "]Übersicht'!$B3"
            
            newSheet.Cells(65536, 1).Formula = strForm
            
               
If IsNumeric(newSheet.Cells(65536, 1)) Then
               lRow = lRow + 1
               newSheet.Cells(lRow, 1) = Bereich(n, 1)
               newSheet.Cells(lRow, 2) = strForm2
               newSheet.Cells(lRow, 2) = newSheet.Cells(lRow, 2).Value
               Bereich(n, 1) = 
""
               
         Application.StatusBar = 
"Durchsuche Datei: """ & fF.Name & _
         
""" ( " & i & " von " & foF.Count & " ) ; Insgesamt gefunden: " & lRow
         
               
End If
            
End If
            
Next
            
         
End If
   
      
Next
   
ERRORHANDLER:

   
If Err.Number = 1004 Then
      Err.Clear
      
Resume Next
   
ElseIf Err.Number <> 0 Then
      MsgBox Err.Description, vbCritical, 
"Fehler"
      
Resume ERROREXIT
   
End If

MsgBox 
"Suche abgeschlossen!"

ERROREXIT:

Set fso = Nothing

Application.ScreenUpdating = 
True
Application.StatusBar = 
False
On Error Resume Next
newSheet.Cells(65536, 1).ClearContents

End Sub 


     Code eingefügt mit Syntaxhighlighter 3.0



Viel Spass und Geduld;-))

Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: kleine korrektur! von: Taz
Geschrieben am: 27.02.2005 10:55:03

Hi Sepp!

GESCHAFFT !!! :))) Problem beseitigt. Mit der letzten Version deines VBA-Codes funktionierts super
Ich hab den Such-Vorgang jetzt mal auf einer übertakteten 2430 Mhz AMD 64 Maschine mit hochgetuntem 1024 MB Speicher durchlaufen lassen...Ging dann natürlich ne Ecke schneller (vorher AMD Duron 1200 Mhz) ;) (wäre übrigens, mal kein schlechter "wirklich realer" Benchmark ... gegenüber den ganzen synthetischen ....)

Es wurden 1276 SrNr gefunden, und der Rest ist wirklich nicht in den Excel Dateien vorhanden. Ich hab da mal stichprobenartig 23 Stück manuell suchen lassen, keine Übereinstimmung.

VVVIIIEEEELLLLLLEEEENNNNNN Dank an dich! Wahnsinn, bist der Beste.
Finde es klasse, dass es noch Leute (und vernüftige Foren) gibt, die sich wirklich die Mühe machen und mit ihrem Wissen anderen noch weiterhelfen.
Also nochmals, danke!

Gruss
Taz


Bild


Betrifft: Freut mich das es klappte! o.T. von: Josef Ehrensberger
Geschrieben am: 27.02.2005 11:14:37

Gruß Sepp


Bild


Betrifft: Replace("klappte", "e", "") ;-)) o.T. von: Josef Ehrensberger
Geschrieben am: 27.02.2005 11:15:51

;-)


Bild


Betrifft: AW: Replace("klappte", "e", "") ;-)) o.T. von: TAZ
Geschrieben am: 27.02.2005 11:23:45

:)
jop, ... wenn dann richtig ...

;)


Bild


Betrifft: AW: suchen in ordnern + rauskopieren von: Dave
Geschrieben am: 25.02.2005 19:19:46

Hi,

falsch angehängt, sollte eigentlich zu diesem Timerproblem.

Dave


 Bild

Beiträge aus den Excel-Beispielen zum Thema "suchen in ordnern + rauskopieren"