Nette(n) Helfer(in) mit schnellem PC gesucht
24.10.2006 22:56:53
Reinhard
mein Rechner braucht ja Stunden bis ich da mehrere Workbooks vollkrieg, denn das will ich noch testen, ob er bei mehreren Workbooks auch noch arbeitet der Code.
Als Suchbegriff kann man bis zu 9 durch Leerzeichen getrennte Begriffe eingeben.
Also so wird die Datei schnell voll, naja halt nur wenn man schnellen Rechner hat.
Suchtext:
*.* *.* *.* *.* *.* *.* *.* *.* *.*
Den Code habe ich umgeschrieben, so dass jetzt bei jedem Durchlauf des Programms
an Suchen.txt angehängt wird.
Habe jetzt eine Suchen.txt von 300MB und 3 Millionen Dateien als Zelleneinträge,
aber bin erst in Spalte BL von Mappe1, und das dauerte schon ewig :-(, deshalb
meine Bitte an Euch.
Zu Starten ist das Makro "Suchen", davor "Hauptverzeichnis" anpassen.
Nebenfrage, wie wird in einem Netzlaufwerk das Laufwerk angesprochen, K:\, K:\\,
K://.... Ich sah da schon was mit zwei Strichen. Und gilt das dann generell für alle Netzlaufwerke, also die die nach außen hin Windows basiert sind.?
Danke ^ Gruß
Reinhard
Option Explicit
'Quelle -ActiveVB.de
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As _
Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
() ' (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Const STILL_ACTIVE = &H103
Const PROCESS_ALL_ACCESS = &H1F0FFF
Dim S&
Private Function IsActive() As Boolean
Dim Handle&, ExitCode&
Handle = OpenProcess(PROCESS_ALL_ACCESS, False, S)
Call GetExitCodeProcess(Handle, ExitCode)
Call CloseHandle(Handle)
IsActive = IIf(ExitCode = STILL_ACTIVE, True, False)
End Function
Function ShellAndWait(FileName As String)
Dim objScript, ShellApp
Set objScript = CreateObject("WScript.Shell")
ShellApp = objScript.Run(FileName, 1, True)
ShellAndWait = True
End Function
Sub Suchen()
Dim S, Datei As String, Zeile As String, Zei As Long, Start, Meldung As String
Dim Hauptverzeichnis, Datei2, N, Spa, Anz, Blatt As String
On Error GoTo Fehler
Hauptverzeichnis = "C:\"
Blatt = ActiveSheet.Name
Range("A:IV").ClearContents
Application.ScreenUpdating = False
Meldung = "Gesuchten Dateinamen oder Teile davon eingeben" & Chr(13)
Meldung = Meldung & "Stellervertreterzeichen ist das " & Chr(34) & "*" & Chr(34) & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "pad" & Chr(34) & " wird nur die Datei namens " & Chr(34) & "pad" & Chr(34) & " gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*pad" & Chr(34) & " wird z.B.: Pad, Autopad , Notpad usw. gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*.xls" & Chr(34) & " werden alle Exceldateien gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*.xls *.doc *.txt" & Chr(34) & " werden alle Excel/Word/Text-Dateien gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "pad*" & Chr(34) & " wird z.B.: pad, pad.exe, padanton.txt gefunden." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*pad*" & Chr(34) & " wird dann z.B. gefunden pad, notepad.exe Bootspaddel.txt usw." & Chr(13)
Meldung = Meldung & "Bei Eingabe von " & Chr(34) & "*.*" & Chr(34) & " wird jede Datei gefunden."
Spa = 3
Datei = InputBox(Meldung)
Datei2 = Split(Datei)
If Datei = "" Then Exit Sub
[A1] = "Start"
[A2] = "Ende"
[A3] = "Diff"
Start = Timer
[b1] = Timer
If Dir("c:\test2/nul") = "" Then MkDir "c:\test2"
Close
Open "c:\test2\Suchen.bat" For Output As #1
Print #1, "@echo off"
Print #1, "echo I'm working..."
Print #1, "dir " & Hauptverzeichnis & Datei2(0) & " /s/b/-p >> c:\test2\Suchen.txt"
For N = 1 To UBound(Datei2)
Print #1, "dir " & Hauptverzeichnis & Datei2(N) & " /s/b/-p >> c:\test2\Suchen.txt"
Next N
Close #1
ShellAndWait ("c:\test2\Suchen.bat")
Open "c:\test2\Suchen.txt" For Input As #1
Zei = 1
While Not EOF(1)
Zei = Zei + 1
If Zei = 65537 Then
Anz = Anz + 65535
Spa = Spa + 1
Zei = 2
End If
If Spa = 257 Then
Zei = 0
Spa = 3
Workbooks.Add
End If
Line Input #1, Zeile
Cells(Zei, Spa) = Zeile
Wend
Anz = Anz + Zei
With ThisWorkbook.Worksheets(Blatt)
If Anz > 1 Then
.Cells(1, 3) = Anz & " Treffer für den Suchbegriff " & Chr(34) & Datei & Chr(34)
Else
.Cells(1, 3) = Chr(34) & Datei & Chr(34) & " wurde nicht gefunden."
End If
Close
.[b2] = Timer
.[B3] = .[b2] - .[b1]
End With
MsgBox Timer - Start & "Sekunden"
Fehler:
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Gruß
Reinhard