Thema Datum  Von Nutzer Rating
Antwort
Rot Verschieben von Unterordnern mit Inhalt
23.11.2021 11:10:15 Paul
NotSolved
23.11.2021 11:36:01 Mase
Solved
23.11.2021 11:37:26 Paul
NotSolved
23.11.2021 12:28:20 Mase
NotSolved
23.11.2021 13:33:44 Paul
NotSolved
23.11.2021 13:44:45 Paul
NotSolved
23.11.2021 14:17:54 Mase
NotSolved
23.11.2021 14:30:31 Gast41014
NotSolved
23.11.2021 14:59:10 Mase
NotSolved
23.11.2021 15:27:31 Gast41014
NotSolved
23.11.2021 14:32:58 Gast7747
NotSolved
23.11.2021 14:47:34 Mase
NotSolved
24.11.2021 15:43:10 Gast22799
NotSolved
23.11.2021 17:19:54 Gast50526
NotSolved
23.11.2021 23:11:19 volti
NotSolved

Ansicht des Beitrags:
Von:
Paul
Datum:
23.11.2021 11:10:15
Views:
114
Rating: Antwort:
  Ja
Thema:
Verschieben von Unterordnern mit Inhalt

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


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Verschieben von Unterordnern mit Inhalt
23.11.2021 11:10:15 Paul
NotSolved
23.11.2021 11:36:01 Mase
Solved
23.11.2021 11:37:26 Paul
NotSolved
23.11.2021 12:28:20 Mase
NotSolved
23.11.2021 13:33:44 Paul
NotSolved
23.11.2021 13:44:45 Paul
NotSolved
23.11.2021 14:17:54 Mase
NotSolved
23.11.2021 14:30:31 Gast41014
NotSolved
23.11.2021 14:59:10 Mase
NotSolved
23.11.2021 15:27:31 Gast41014
NotSolved
23.11.2021 14:32:58 Gast7747
NotSolved
23.11.2021 14:47:34 Mase
NotSolved
24.11.2021 15:43:10 Gast22799
NotSolved
23.11.2021 17:19:54 Gast50526
NotSolved
23.11.2021 23:11:19 volti
NotSolved