Frage: Zwei Dinge - zum Einen habe ich eine Liste mit Dateinamen in Spalte A, zum Zweiten möchte ich den Dateinamen in Zelle A1 eingeben. Der Speicherort der jeweiligen Datei ist nicht bekannt. Ein Hyperlink soll in Spalte B eingefügt werden. Optional möchte ich die Dateien in ein Verzeichnis mit Ordnerauswahl kopieren. Wie geht das?
Two things - first I have a list of file names in column A, secondly I would like to enter the file name in cell A1. The location of the file is unknown. A hyperlink will be inserted in column B. Optional I want to copy the files into a folder with folder selection. How does it work?
Hier noch eine Beispieldatei / Here's a sample file:
Datei suchen - Pfad unbekannt - Hyperlink - API...[ZIP 3 MB]
Code gehört in Sheet1 / Code belongs in Sheet1:
Code gehört in Sheet2 / Code belongs in Sheet2:
Code gehört in ein Modul / Code belongs in a module:
Code gehört in ein Modul / Code belongs in a module:
Two things - first I have a list of file names in column A, secondly I would like to enter the file name in cell A1. The location of the file is unknown. A hyperlink will be inserted in column B. Optional I want to copy the files into a folder with folder selection. How does it work?
Hier noch eine Beispieldatei / Here's a sample file:
Datei suchen - Pfad unbekannt - Hyperlink - API...[ZIP 3 MB]
Code gehört in Sheet1 / Code belongs in Sheet1:
OptionExplicit PrivateDeclareFunction SearchTreeForFile Lib"imagehlp.dll" _ (ByVal RootPath AsString, ByVal InputPathName AsString, _ ByVal OutputPathBuffer AsString) AsLong '-------------------------------------------------------------------------- ' Module : Sheet1 ' Procedure : Worksheet_Change ' Author : Case (Ralf Stolzenburg) ' Date : 29.01.2013 ' Purpose : File Search - location unknown - API... '-------------------------------------------------------------------------- PrivateSub Worksheet_Change(ByVal Target As Range) ' Variablendeklaration ' Stringvariable mit Puffer Dim strPathName AsString * 255 Dim strName AsString Dim lngCalc AsLong Dim lngTMP AsLong ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke OnErrorGoTo Fin ' Wenn nicht mehr als eine Zelle gewählt wurde, dann... IfNot Target.Count > 1Then ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten With Application ' Das Bildschirmaktualisierung wird unterbrochen .ScreenUpdating = False ' Ereignisroutinen werden deaktiviert .EnableEvents = False ' Auslesen der momentanen Einstellung für die Berechnung lngCalc = .Calculation ' Setzen der Berechnung auf "Manuell" .Calculation = xlCalculationManual ' Eingabeaufforderungen und Warnmeldungen unterdrücken .DisplayAlerts = False EndWith ' Wenn es A1 ist dann... If Target.Address(False, False) = "A1"Then ' Wenn A1 nicht leer ist, dann... If Trim(Target.Value) <> ""Then ' Variable lngTMP <> 0 - Datei ist vorhanden lngTMP = SearchTreeForFile(ThisWorkbook.Path & _ Application.PathSeparator, Target.Text, strPathName) ' Variable lngTMP = 0 - Datei nicht vorhanden If lngTMP = 0Then MsgBox "File not found!", vbInformation, "Info" Else ' Puffer zurechtstutzen, überflüssige Leerzeichen weg strPathName = Left$(strPathName, _ InStr(1, strPathName, vbNullChar) - 1) strName = RTrim(strPathName) ' In B1 schreiben Target.Offset(, 1).Value = strName ' Hyperlink in B1 auf gefundene Datei setzen Target.Offset(, 1).Hyperlinks.Add _ Anchor:=Target.Offset(, 1), Address:=strName EndIf Else ' sonst - A1 ist leer, also lösche B1 Target.Offset(, 1).Clear EndIf EndIf EndIf Fin: ' Die Applikation aufwecken With Application ' Bildschirmaktualisierung wieder einschalten .ScreenUpdating = True ' Ereignisroutinen werden wieder aktiviert .EnableEvents = True ' Setzen der Berechnung auf den gemerkten Wert .Calculation = lngCalc ' Eingabeaufforderungen und Warnmeldungen wieder zulassen .DisplayAlerts = True ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens .CutCopyMode = True EndWith ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung If Err.Number <> 0Then MsgBox "Error: "& _ Err.Number &" "& Err.Description EndSub
Code gehört in Sheet2 / Code belongs in Sheet2:
OptionExplicit PrivateDeclareFunction SearchTreeForFile Lib"imagehlp.dll" _ (ByVal RootPath AsString, ByVal InputPathName AsString, _ ByVal OutputPathBuffer AsString) AsLong '-------------------------------------------------------------------------- ' Module : Sheet2 ' Procedure : Worksheet_Change ' Author : Case (Ralf Stolzenburg) ' Date : 29.01.2013 ' Purpose : File Search - location unknown - API... '-------------------------------------------------------------------------- ' Dateierweiterung gegebenenfalls anpassen!!! Const strEX AsString = ".pdf" PrivateSub Worksheet_Change(ByVal Target As Range) ' Variablendeklaration ' Stringvariable mit Puffer Dim strPathName AsString * 255 Dim strName AsString Dim lngCalc AsLong Dim lngTMP AsLong ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke OnErrorGoTo Fin ' Wenn nicht mehr als eine Zelle gewählt wurde, dann... IfNot Target.Count > 1Then ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten With Application ' Das Bildschirmaktualisierung wird unterbrochen .ScreenUpdating = False ' Ereignisroutinen werden deaktiviert .EnableEvents = False ' Auslesen der momentanen Einstellung für die Berechnung lngCalc = .Calculation ' Setzen der Berechnung auf "Manuell" .Calculation = xlCalculationManual ' Eingabeaufforderungen und Warnmeldungen unterdrücken .DisplayAlerts = False EndWith ' Wenn es A1 ist dann... If Target.Address(False, False) = "A1"Then ' Wenn A1 nicht leer ist, dann... If Trim(Target.Value) <> ""Then ' Variable lngTMP <> 0 - Datei ist vorhanden lngTMP = SearchTreeForFile(ThisWorkbook.Path & _ Application.PathSeparator, Target.Text & strEX, strPathName) ' Variable lngTMP = 0 - Datei nicht vorhanden If lngTMP = 0Then MsgBox "File not found!", vbInformation, "Info" Else ' Puffer zurechtstutzen, überflüssige Leerzeichen weg strPathName = Left$(strPathName, _ InStr(1, strPathName, vbNullChar) - 1) strName = RTrim(strPathName) ' In B1 schreiben Target.Offset(, 1).Value = strName ' Hyperlink in B1 auf gefundene Datei setzen Target.Offset(, 1).Hyperlinks.Add _ Anchor:=Target.Offset(, 1), Address:=strName EndIf Else ' sonst - A1 ist leer, also lösche B1 Target.Offset(, 1).Clear EndIf EndIf EndIf Fin: ' Die Applikation aufwecken With Application ' Bildschirmaktualisierung wieder einschalten .ScreenUpdating = True ' Ereignisroutinen werden wieder aktiviert .EnableEvents = True ' Setzen der Berechnung auf den gemerkten Wert .Calculation = lngCalc ' Eingabeaufforderungen und Warnmeldungen wieder zulassen .DisplayAlerts = True ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens .CutCopyMode = True EndWith ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung If Err.Number <> 0Then MsgBox "Error: "& _ Err.Number &" "& Err.Description EndSub
Code gehört in ein Modul / Code belongs in a module:
OptionExplicit PrivateDeclareFunction SearchTreeForFile Lib"imagehlp.dll" _ (ByVal RootPath AsString, ByVal InputPathName AsString, _ ByVal OutputPathBuffer AsString) AsLong '-------------------------------------------------------------------------- ' Module : Module1 ' Procedure : Main ' Author : Case (Ralf Stolzenburg) ' Date : 29.01.2013 ' Purpose : File Search - location unknown - API... '-------------------------------------------------------------------------- ' Dateierweiterung gegebenenfalls anpassen!!! Const strEX AsString = ".pdf" PublicSub Main() ' Variablendeklaration ' Stringvariable mit Puffer Dim strPathName AsString * 255 Dim lngLastRow AsLong Dim strName AsString Dim lngCalc AsLong Dim lngTMP AsLong ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke OnErrorGoTo Fin ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten With Application ' Das Bildschirmaktualisierung wird unterbrochen .ScreenUpdating = False ' Ereignisroutinen werden deaktiviert .EnableEvents = False ' Auslesen der momentanen Einstellung für die Berechnung lngCalc = .Calculation ' Setzen der Berechnung auf "Manuell" .Calculation = xlCalculationManual ' Eingabeaufforderungen und Warnmeldungen unterdrücken .DisplayAlerts = False EndWith ' Sheet3 ist der CODENAME / OBJEKTNAME eines Tabellenblattes ' in einem englischen Excel ' In deutsch dann Tabelle3 With Sheet3 ' Letzte Teile Spalte A ermitteln lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _ .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) ' Schleife über Zeilen For lngLastRow = 1To lngLastRow ' Variable lngTMP <> 0 - Datei ist vorhanden lngTMP = SearchTreeForFile(ThisWorkbook.Path & _ Application.PathSeparator, .Cells(lngLastRow, 1).Text & _ strEX, strPathName) ' Variable lngTMP = 0 - Datei nicht vorhanden If lngTMP = 0Then ' Text in Spalte B schreiben .Cells(lngLastRow, 2).Value = "File not found!" Else ' Puffer zurechtstutzen, überflüssige Leerzeichen weg strPathName = Left$(strPathName, _ InStr(1, strPathName, vbNullChar) - 1) strName = RTrim(strPathName) ' In B schreiben .Cells(lngLastRow, 2).Value = strName ' Hyperlink in B auf gefundene Datei setzen .Cells(lngLastRow, 2).Hyperlinks.Add _ Anchor:=.Cells(lngLastRow, 2), Address:=strName EndIf ' Nächste Zeile Next lngLastRow ' Spalte A und B optimale Breite einstellen .Columns("A:B").AutoFit EndWith Fin: ' Die Applikation aufwecken With Application ' Bildschirmaktualisierung wieder einschalten .ScreenUpdating = True ' Ereignisroutinen werden wieder aktiviert .EnableEvents = True ' Setzen der Berechnung auf den gemerkten Wert .Calculation = lngCalc ' Eingabeaufforderungen und Warnmeldungen wieder zulassen .DisplayAlerts = True ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens .CutCopyMode = True EndWith ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung If Err.Number <> 0Then MsgBox "Error: "& _ Err.Number &" "& Err.Description EndSub
Code gehört in ein Modul / Code belongs in a module:
OptionExplicit PrivateDeclareFunction SearchTreeForFile Lib"imagehlp.dll" _ (ByVal RootPath AsString, ByVal InputPathName AsString, _ ByVal OutputPathBuffer AsString) AsLong '-------------------------------------------------------------------------- ' Module : Module2 ' Procedure : Main_1 ' Author : Case (Ralf Stolzenburg) ' Date : 29.01.2013 ' Purpose : File Search - location unknown - API... '-------------------------------------------------------------------------- ' Dateierweiterung gegebenenfalls anpassen!!! Const strEX AsString = ".pdf" PublicSub Main_1() ' Variablendeklaration ' Stringvariable mit Puffer Dim strPathName AsString * 255 Dim strDestFolder AsString Dim lngLastRow AsLong Dim strName AsString Dim lngCalc AsLong Dim lngTMP AsLong ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke OnErrorGoTo Fin ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten With Application ' Das Bildschirmaktualisierung wird unterbrochen .ScreenUpdating = False ' Ereignisroutinen werden deaktiviert .EnableEvents = False ' Auslesen der momentanen Einstellung für die Berechnung lngCalc = .Calculation ' Setzen der Berechnung auf "Manuell" .Calculation = xlCalculationManual ' Eingabeaufforderungen und Warnmeldungen unterdrücken .DisplayAlerts = False EndWith If fncFolder(strDestFolder) <> ""Then ' Sheet3 ist der CODENAME / OBJEKTNAME eines Tabellenblattes ' in einem englischen Excel ' In deutsch dann Tabelle3 With Sheet3 ' Letzte Teile Spalte A ermitteln lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _ .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) ' Schleife über Zeilen For lngLastRow = 1To lngLastRow ' Variable lngTMP <> 0 - Datei ist vorhanden lngTMP = SearchTreeForFile(ThisWorkbook.Path & _ Application.PathSeparator, .Cells(lngLastRow, 1).Text & _ strEX, strPathName) ' Variable lngTMP = 0 - Datei nicht vorhanden If lngTMP = 0Then ' Text in Spalte B schreiben .Cells(lngLastRow, 3).Value = "Not copied!" Else ' Puffer zurechtstutzen, überflüssige Leerzeichen weg strPathName = Left$(strPathName, _ InStr(1, strPathName, vbNullChar) - 1) strName = RTrim(strPathName) FileCopy strName, strDestFolder & Mid(strName, _ InStrRev(strName, "\", -1) + 1) EndIf ' Nächste Zeile Next lngLastRow ' Spalte A, B und C optimale Breite einstellen .Columns("A:C").AutoFit EndWith EndIf Fin: ' Die Applikation aufwecken With Application ' Bildschirmaktualisierung wieder einschalten .ScreenUpdating = True ' Ereignisroutinen werden wieder aktiviert .EnableEvents = True ' Setzen der Berechnung auf den gemerkten Wert .Calculation = lngCalc ' Eingabeaufforderungen und Warnmeldungen wieder zulassen .DisplayAlerts = True ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens .CutCopyMode = True EndWith ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung If Err.Number <> 0Then MsgBox "Error: "& _ Err.Number &" "& Err.Description EndSub '-------------------------------------------------------------------------- ' Module : Module2 ' Procedure : fncFolder ' Author : Case (Ralf Stolzenburg) ' Date : 29.01.2013 ' Purpose : Folder selection... '-------------------------------------------------------------------------- PrivateFunction fncFolder(strTMPFolder AsString) AsString With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = "C:\" .Title = "Folder" .ButtonName = "Choice..." .InitialView = msoFileDialogViewList If .Show = -1 Then strTMPFolder = .SelectedItems(1) strTMPFolder = IIf(Right(strTMPFolder, 1) <> "\", _ strTMPFolder &"\", strTMPFolder) Else fncFolder = "" EndIf EndWith fncFolder = strTMPFolder EndFunction