|
Guten Tag,
ich wende mich verzweifelt an das VBA-Forum in der Hoffnung auf Hilfe...
Der erstellte Code soll ausgewählte Ordner auslesen und ausgewählte Dateien in einen anderen Ordner verschieben.
Das Problem stellen in diesem Falle die Unterordner dar. Diese lassen sich nicht so einfach verschieben da erstmal ein identischer (Unter)Ordner in dem neuen Ordner angelegt werden müsste bevor die Dateien überhaupt verschoben werden könnten.
Ich bin leider ratlos... habe es jetzt auch mit einem Array versucht aber leider funktioniert dies auch nicht.
Vielen Dank schonmal im voraus für Ihre Mühe!
Der Code:
Public i As Long
Public zeile As Integer
Public objFileSystem As Object
Public objVerzeichnis As Object
Public Seriennummer As String
Public objUnterordner As Object
Public objDatei As Object
'Pfad = "C:\Users\Z0010395\Downloads"
Sub Unterordner_verschieben()
Dim objFSO As Object
Dim objFolder As Object
Dim strPfad As String
Dim objSubfolder As Object, colSubfolders As Object
Dim i As Integer
Dim UnterordnerArray(1 To 200) As Variant
strPfad = "C:\Users\Z0010395\Downloads\" & Seriennummer
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.SubFolders
For Each objSubfolder In colSubfolders
UnterordnerArray = objSubfolder.Name
Next objSubfolder
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing
MsgBox UnterordnerArray
End Sub
Public Sub CheckBox1_Click()
Dim i As Long
zeile = 2
'If ActiveSheet.OLEObjects("CheckBox1_Click").Object.Value = True Then
If CheckBox1.Value = True Then
Do Until Cells(zeile, 1) = "1"
Cells(zeile, 1).Value = "x"
zeile = zeile + 1
Loop
End If
End Sub
Private Sub Unterordnerinclude()
End Sub
Public Sub CheckBox2_Click()
End Sub
Private Sub ComboBox1_Change()
End Sub
Sub CommandButton1_Click()
Dim zaehlerDateien As Integer
Dim zaehlerAuslese As Integer
Dim zelle As Integer
Dim dateienArray(1 To 200) As String
Dim zeile As Integer
Dim FSO As New FileSystemObject
Dim Seriennummer As String
Seriennummer = ComboBox1.Value
'Bei einem Laufwerksfehler wird fortgesetzt
'On Error Resume Next
zaehlerDateien = 1
zeile = 2
Seriennummer = ComboBox1.Value
Call CheckBox1_Click
Call CheckBox2_Click
'Eine Schleife die die Zeilen durch geht bis zu der "1" die wir angelegt haben
Do Until Cells(zeile, 1) = "1"
'Sofern in der ersten Zeile ein Zeichen oder Symbol ist geht es in die If-Abfrage
If Cells(zeile, 1) <> "" Then
'Füllt das Array mit den Werten (also den Dateinamen)
dateienArray(zaehlerDateien) = Cells(zeile, 2).Value
'Für die entsprechende Anzahl der zu verschiebenen Dateien
zaehlerDateien = zaehlerDateien + 1
End If
zeile = zeile + 1
Loop
'Damit sich der entsprechende Ordner mit Versionsnummer erstellt
Call CreateFolder("C:\Users\Z0010395\Documents\" & Seriennummer)
'Damit die Unterordner berücksichtigt werden oder nicht
If CheckBox2.Value = True Then
Call Unterordner_verschieben
Else
Resume
End If
'Damit alle makierten Daten verschoben werden
For zaehlerAuslese = 1 To zaehlerDateien
'Verschiebt die makierten Dateien über das angelegte Array
FSO.MoveFile "C:\Users\Z0010395\Downloads\" & Seriennummer & "\" & dateienArray(zaehlerAuslese), C:\Users\Z0010395\Documents\" & Seriennummer & "_V" & i & "\"
MsgBox "Die ausgewälten Dateien : " & dateienArray(zaehlerAuslese) & " wurden verschoben"
'Benachrichtigung ob die Datei verschoben wurde
Next zaehlerAuslese
'Damit sich das Tabellenblatt aktualisiert nachdem verschieben von Dateien
Call Dateien_auslesen_Click
'Damit sich nach dem verschieben der entsprechnede Ordner öffnet
Shell "Explorer /e,C:\Users\Z0010395\Documents\ & Seriennummer & "_V" & i, vbNormalFocus
End Sub
Private Sub CommandButton2_Click()
Dim fs, f, f1, fc, s
Dim folderspec
folderspec = "C:\Users\Z0010395\Downloads\"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.SubFolders
ComboBox1.Clear
For Each f1 In fc
ComboBox1.AddItem f1.Name
Next f1
ComboBox1.Activate
Application.SendKeys "^{F4}"
End Sub
Private Sub Dateien_auslesen_Click()
Dim lngZeile As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Dim Seriennummer As String
Dim Pfad As String
Rows("2:65536").ClearContents 'Löscht den Inhalt
Seriennummer = ComboBox1.Value
Pfad = "C:\Users\Z0010395\Downloads\" 'Um später den Pfad anzupassen
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(Pfad & Seriennummer)
Set objDateienliste = objVerzeichnis.Files
'ActiveSheet.Unprotect Password:="TestPW" 'Hebt den Blattschutz auf
lngZeile = 2
For Each objDatei In objDateienliste
If Not objDatei Is Nothing Then
ActiveSheet.Cells(lngZeile, 2).Activate
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="C:\Users\Z0010395\Downloads\" & Seriennummer & "\" & objDatei.Name, TextToDisplay:=objDatei.Name
'ActiveSheet.Cells(lngZeile, 3) = objDatei.Path 'Gibt den Pfad an
lngZeile = lngZeile + 1
End If
Next objDatei
Call UnterOrdnerAuslesen(objVerzeichnis)
Exit Sub
End Sub
Sub UnterOrdnerAuslesen(ByVal strDateipfad As String)
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objUnterordner As Object
Dim objDatei As Object
Dim i As Long
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(strDateipfad)
If Cells(Rows.Count, 2).End(xlUp).Row > 1 Then
i = Cells(Rows.Count, 2).End(xlUp).Row + 1
Else
i = 1
End If
For Each objUnterordner In objVerzeichnis.SubFolders
For Each objDatei In objUnterordner.Files
If Not objDatei Is Nothing And Not Right(LCase(objDatei.Name), 4) = ".beispiel" Then 'Falls man ein bestimmtes Dateiformat ausschließen möchte
'ActiveSheet.Cells(i, 1) = objDatei.Name 'Gibt die Namen der Daten aus
'MsgBox objDatei
ActiveSheet.Cells(i + 1, 2).Activate
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objDatei, TextToDisplay:=objDatei.Name
'ActiveSheet.Cells(i, 3) = objUnterordner.Name 'Gibt den Pfad an
i = i + 1
End If
Next objDatei
Next objUnterordner
ActiveSheet.Cells(i + 1, 1).Value = " 1" 'Begrenzung zum makieren
'ActiveSheet.Protect Password:="TestPW",
UserInterfaceOnly = True
DrawingObjects = True
Contents = True
End Sub
Private Sub dateien_hochladen_Click()
Seriennummer = ComboBox1.Value
Call CreateFolder("C:\Users\Z0010395\Documents\" & Seriennummer)
End Sub
Sub CreateFolder(ByVal Folder As String)
Dim strFolder As String
Dim Pfad As String
Seriennummer = ComboBox1.Value
i = 1
With CreateObject("Scripting.FileSystemObject")
strFolder = Folder
Do
If .FolderExists(Folder & "_V" & i) Then
' strFolder = strFolder & "_V" & i
strFolder = .GetFolder(Folder) & "_V" & i
i = i + 1
Else
Call .CreateFolder(Folder & "_V" & i)
Exit Do
End If
Loop
End With
Pfad = "C:\Users\Z0010395\Documents\"
End Sub
|