Bboy.Endless
Newbie
- Registriert
- Okt. 2017
- Beiträge
- 3
Hallo Community,
Ich bräuchte mal Hilfe von euch
Ich hab in einem Ordner mehrere Unterordner von Fotos, und möchte diese mithilfe eines Makros als namen in Excel stehen haben..
Ich habe auch schon ein Makro, nur schreibt er mir hierbei den kompletten Pfad als Namen hin.. leider bin ich nicht so mächtig mit dem entwerfen, und hoffe einer von euch kann mir da weiter helfen.
Leider muss ich auch hier, wenn ein neuer Ordner hinzu kommt immer wieder das Makro neu ausführen, und sachen die in den Spalten dahinter stehen verschieben sich dann natürlich nicht mit..
Vielen dank schon mal
Option Explicit
Dim z
Public Sub Aufruf()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Set objShell = CreateObject("Shell.Application")
With objShell
Set objFolder = .BrowseForFolder(0&, "Was soll ich machen?", 0, "D:\Eigene Dateien")
End With
If Not objFolder Is Nothing Then
Set objItem = objFolder.Self
Else: Exit Sub
End If
z = 1
Schreiben objItem.Path, True 'true wenn die Unterordner auch wieder geschrieben werden sollen
'Sonst false oder weglassen
End Sub
Public Sub Schreiben(V, Optional sbfolds As Boolean = False)
Dim fso As Object
Dim datei
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set datei = fso.GetFolder(V)
Select Case sbfolds
Case True
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Schreiben Unterordner, True
Next
Case False
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Next
End Select
Set fso = Nothing
Set datei = Nothing
End Sub
Ich bräuchte mal Hilfe von euch
Ich hab in einem Ordner mehrere Unterordner von Fotos, und möchte diese mithilfe eines Makros als namen in Excel stehen haben..
Ich habe auch schon ein Makro, nur schreibt er mir hierbei den kompletten Pfad als Namen hin.. leider bin ich nicht so mächtig mit dem entwerfen, und hoffe einer von euch kann mir da weiter helfen.
Leider muss ich auch hier, wenn ein neuer Ordner hinzu kommt immer wieder das Makro neu ausführen, und sachen die in den Spalten dahinter stehen verschieben sich dann natürlich nicht mit..
Vielen dank schon mal
Option Explicit
Dim z
Public Sub Aufruf()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Set objShell = CreateObject("Shell.Application")
With objShell
Set objFolder = .BrowseForFolder(0&, "Was soll ich machen?", 0, "D:\Eigene Dateien")
End With
If Not objFolder Is Nothing Then
Set objItem = objFolder.Self
Else: Exit Sub
End If
z = 1
Schreiben objItem.Path, True 'true wenn die Unterordner auch wieder geschrieben werden sollen
'Sonst false oder weglassen
End Sub
Public Sub Schreiben(V, Optional sbfolds As Boolean = False)
Dim fso As Object
Dim datei
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set datei = fso.GetFolder(V)
Select Case sbfolds
Case True
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Schreiben Unterordner, True
Next
Case False
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Next
End Select
Set fso = Nothing
Set datei = Nothing
End Sub