Clever-Excel-Forum

Clever-Excel-Forum > Office-Anwendungen > Excel > VBA Ordner suchen und kopieren
Normale Version: VBA Ordner suchen und kopieren
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.

ZimmerMichl

25.04.2018, 13:33
Hallo liebes Forum,

ich bin auf der Suche nach  einem VBA, welcher mir ermöglicht, einen Vorlageordner zu kopieren und umbenennen.
Im Explorer herrscht folgende Struktur:
C:\Desktop\Kunde\F\Vorlage
Nun soll anhand des Codes die letzte Zeile in Spalte E (Kundenname) der passende Ordner auf C:\Desktop\Kunde gesucht werden.
Dann soll beim passenden Kunden der Ordner "Vorlage" kopiert und umbenannt werden in "Auftragsnummer_Beschreibung"(letzte Zeile Spalte B &"_"& Spalte C).
Dabei muss geprüft werden, ob dieser Ordner nicht zufällig schon existiert.

Aufgrund Dropdown ist gewährleistet, dass die Ordnernamen im Explorer mit den Kundennamen in der Tabelle zu 100% übereinstimmen.

Ich hoffe, dass ich mich verständlich ausgedrückt habe.

Vielen Dank schon mal im Voraus für eure Unterstützung.

Wastl

26.04.2018, 11:47
Hallo Zimmermichl,

ohne die Datei angeschaut zu haben mal eine Frage:

Wenn ich die Datei A.xlsx in Ordner B speichere, gibt es 2 Möglichkeiten:
1. Speichern klappt -> Datei A.xlsx hat davor dort noch nicht existiert.
2. Speichern klappt nicht -> die Datei gibts schon.

Ist die Prüfung damit nicht schon erledigt?

ZimmerMichl

26.04.2018, 12:25
Hallo Wastl,

es geht hierbei nicht um die Excel, die dort gespeichert werden soll.

Die Aufgabe des Codes soll sein, einen Ordner mit Unterstruktur (Vorlage) zu kopieren und um zu benennen.
In der Datei sind lediglich die Kunden mit den einzelnen Auftragsnummern gelistet.
So kann zum Beispiel sein, dass Kunde A 15 verschiedene Auftragsnummern hat.
Der Code muss also nun in "C:\Desktop\Kunde" Kunde A suchen, dort den Ordner "Vorlage" kopieren und umbenennen. Dabei noch prüfen, ob es diesen nicht schon gibt.

Anbei das Beispiel der Ordnerstruktur

Wastl

26.04.2018, 13:02
Hi Michl,

das ist nicht trivial.
Hab ich schon mal gemacht.
Du musst als erstes das Ziel-Verzeichnis auslesen und in eine Tabelle schreiben.
Dabei ist mir nicht gelungen, das über mehrere Tiefen auf eimal zu machen, sondern nur mit Schleife. verteilt auf mehrere Blätter
Wenn du das Ergebnis in Excel stehen hast, muss dein Code entscheiden, wo die Vorlage hinkopiert werden soll.
und diese umbenennen war bei mir nicht nötig.
Ich saß bei meiner Aufgabe längere Zeit (1 Woche dran) bis es so funktionierte, wie ich wollte.

Ich poste dir mal den Code, vielleicht kannste was davon übernehmen:

Code:
Option Explicit
Dim strPfad As String    ' Suchpfad zum Auslesen Firmen
Dim lngNext As Long      ' Zähler zum Auslesen
Dim strFirma As String   ' Gefundendene Firma für Auslesen Projekte
Dim VX                   ' Feldvariable um Schreibvorgang Projekt und Firmen zu beschleunigen
Dim strLaufW As String   '

Private Sub Ordnername_einlesen()
' jsks: Verwendet auch Variablen, die auf Modul-Ebene dimensioniert sind
'  Dim strPfad As String # verlegt auf Modulebene
'  Dim lngNext As Long # verlegt auf Modulebene
'  strPfad = "K:\" # verlegt auf Modulebene

 Dim objFSO As Object
 Dim objFolder As Object
 Dim objSubfolder As Object, colSubfolders As Object
 
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objFolder = objFSO.GetFolder(strPfad)
 Set colSubfolders = objFolder.Subfolders
 
'  lngNext = Application.Max(2, Cells(Rows.Count, 1).End(xlUp).Row + 1)
 
 For Each objSubfolder In colSubfolders
   If IsError(Application.Match(objSubfolder.Name, Columns(1), 0)) Then
'      Cells(lngNext, 1).Value = objSubfolder.Name
'      Cells(lngNext, 2).Value = strFirma
     VX(lngNext - 1, 1) = objSubfolder.Name
     VX(lngNext - 1, 2) = strFirma
     lngNext = lngNext + 1
   End If
 Next objSubfolder
 
 Set objFolder = Nothing
 Set colSubfolders = Nothing
 Set objFSO = Nothing
End Sub

Private Sub Projektname_einlesen()
' jsks: Damit wird Tabellenblatt Projekt gefüllt
' jsks: Verwendet auch Variablen, die auf Modul-Ebene dimensioniert sind
' jsks: Dim strFirma As String # verlegt auf Modulebene
Dim int_i As Integer
ReDim VX(1 To 10000, 1 To 2) As Variant

lngNext = 2

ThisWorkbook.Sheets("Projekt").Range("A2:B11000").Clear
ThisWorkbook.Sheets("Projekt").Columns(1).NumberFormat = "@"
' jsks: auskommentieren nächste Zeile
ThisWorkbook.Sheets("Projekt").Activate

For int_i = 2 To ThisWorkbook.Sheets("Datenpflege").Range("B1")
   If ThisWorkbook.Sheets("Firmen").Cells(int_i, 1) = "" Then Exit For
   strFirma = ThisWorkbook.Sheets("Firmen").Cells(int_i, 1)
   strPfad = strLaufW & strFirma & "\"
   Call Ordnername_einlesen
'' jsks: auskommentieren nächste Zeile
'    Cells(lngNext, 1).Select
Next int_i
ThisWorkbook.Sheets("Projekt").Range("A2:B10002") = VX
End Sub
'--------------------------------
Private Sub Firmen_einlesen()
' jsks: Verwendet auch Variablen, die auf Modul-Ebene dimensioniert sind
' jsks: Füllt Tabellenblatt Firmen und schreibt Formel in Zelle B2
ReDim VX(1 To 1000, 1 To 2) As Variant
lngNext = 2

ThisWorkbook.Sheets("Firmen").Activate
strPfad = strLaufW
ThisWorkbook.Sheets("Firmen").Range("A2:A" & ThisWorkbook.Sheets("Datenpflege").Range("B1")).Clear
Call Ordnername_einlesen
ThisWorkbook.Sheets("Firmen").Range("A2:B1002") = VX
ThisWorkbook.Sheets("Firmen").Range("B2:B" & lngNext + 100).FormulaLocal = "=WENN(ISTZAHL(FINDEN(""."";RECHTS(A2;8)));TEIL(RECHTS(A2;8);FINDEN(""."";RECHTS(A2;8))+1;99);"""")"
ThisWorkbook.Sheets("Datenpflege").Range("B3") = lngNext - 1
'Projektname_einlesen
End Sub

Private Sub jsks_copy_folder()
' jsks: nicht mehr verwendet, Versuchsballon
   Dim Neu_Ordn_Name As Variant
   Dim FsyObjekt As Object
   
   Neu_Ordn_Name = "Tesat"
   
   Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
   MkDir "C:\temp\" & Neu_Ordn_Name
   FsyObjekt.CopyFolder "K:\# --Musterprojekt - TD", "c:\Temp\" & Neu_Ordn_Name
End Sub

Private Sub Firma_auswaehlen()
' jsks: Damit werden neue Projekte zu den vorhandenen Firmen angelegt im Laufwerk K:\
' jsks: Verwendet auch Variablen, die auf Modul-Ebene dimensioniert sind
Dim strOrdner_Custom As Variant
Dim strProjekt As Variant
Dim FsyObjekt As Object
Dim a

strProjekt = ThisWorkbook.Sheets("R1 - Projekte").Cells(Selection.Row, 1)
'strOrdner_Custom = InputBox("Ordner auswählen", strProjekt, ThisWorkbook.Sheets("R1 - Projekte").Cells(Selection.Row, 10))
strOrdner_Custom = ThisWorkbook.Sheets("R1 - Projekte").Cells(Selection.Row, 10)

If strOrdner_Custom = "" Then Exit Sub

ChDir strLaufW & strOrdner_Custom
strPfad = strLaufW & strOrdner_Custom
'ThisWorkbook.Sheets("ttt").Activate
'ThisWorkbook.Sheets("ttt").Cells.Clear
'ThisWorkbook.Sheets("ttt").Cells(1, 1) = strPfad
'Call Ordnername_einlesen

'a = MsgBox("Projekt nicht vorhanden?" & vbCrLf & "Anlegen?", vbOKCancel, strProjekt)
'Stop
'If a <> 1 Then Exit Sub
On Error GoTo Faehler
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
MkDir strPfad & "\" & strProjekt
FsyObjekt.CopyFolder "K:\# --Musterprojekt - TD", strPfad & "\" & strProjekt
ThisWorkbook.Sheets("R1 - Projekte").Activate
'ThisWorkbook.Sheets("R1 - Projekte").Cells(Selection.Row, 12).Select
'ThisWorkbook.Sheets("R1 - Projekte").Cells(Selection.Row, 12).FormulaR1C1 = "erledigt"
Exit Sub
Faehler:
a = MsgBox("Da stimmt was nicht" & vbCrLf & strProjekt & vbCrLf & "schon vorhanden", vbOKOnly, "Fäähler")
End Sub
'------------------------------------------------------------------------------------------------------
Private Sub Firma_anlegen()
Dim strOrdner_Custom As Variant

Dim strOrdner_Custom_neu As String
Dim strKostenstelle As String
Dim strAngelProjekt As String
Dim strCustomerNr As String
Dim strPasst As String
Dim strTest As String
Dim strProjektstatus As String
Dim intAnzahlZeichenFirma As Integer

Dim int_i As Integer
Dim int_Datenpflege As Integer

Dim boolOrdner_anlegen As Boolean

intAnzahlZeichenFirma = ThisWorkbook.Sheets("Datenpflege").Range("B4")
strPfad = strLaufW
int_i = 3
' jsks: Prüfen ob in Spalte A was steht
While ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 1) <> ""
boolOrdner_anlegen = False

'###########
   ThisWorkbook.Sheets("R1 - Projekte").Activate
   ThisWorkbook.Sheets("R1 - Projekte").Range("A" & int_i, "L" & int_i).Select
'If int_i = 92 Then Stop
'###########
   strKostenstelle = ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 8)
   strCustomerNr = ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 4)
   strProjektstatus = ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 6)
' jsks: Prüfen ob Projektstatus = "Freigegeben"
   If strProjektstatus = "Freigegeben" Then
   
' jsks: Prüfen ob zu Karlsruhe = beinhaltet "ka"
       strTest = InStr(1, LCase(strKostenstelle), LCase(ThisWorkbook.Sheets("Datenpflege").Range("B2")), vbTextCompare)
       If strTest > 0 Then
           strOrdner_Custom = ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 10)
' jsks: Prüfen ob Firma schon angelegt
           If IsError(strOrdner_Custom) Then
' jsks: Firma noch nicht angelegt
'            Stop
               strOrdner_Custom_neu = ThisWorkbook.Sheets("R1 - Projekte").Range("E" & int_i)
               If Len(strOrdner_Custom_neu) > intAnzahlZeichenFirma Then
                   strOrdner_Custom_neu = Left(strOrdner_Custom_neu, intAnzahlZeichenFirma) & "." & strCustomerNr
               Else
                   strOrdner_Custom_neu = strOrdner_Custom_neu & "." & strCustomerNr
'            Stop
               End If
               boolOrdner_anlegen = True
           Else
' jsks: Firma schon angelegt
'            Stop
               strAngelProjekt = ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 9)
           End If
           
           If strCustomerNr = "#" Then
           Else
'                Stop
' jsks: Wenn Spalte A mit Spalte I zusammenpasst nix machen
               strPasst = InStr(1, strAngelProjekt, ThisWorkbook.Sheets("R1 - Projekte").Cells(int_i, 1), vbTextCompare)
               If strPasst > 0 Then
               Else
                   If boolOrdner_anlegen = True Then
                   ThisWorkbook.Sheets("Firmen").Cells(ThisWorkbook.Sheets("Datenpflege").Range("B3") + 1, 1) = strOrdner_Custom_neu
                   ThisWorkbook.Sheets("Datenpflege").Range("B3") = ThisWorkbook.Sheets("Datenpflege").Range("B3") + 1
                   ChDir strLaufW
                   MkDir strLaufW & strOrdner_Custom_neu
                   int_Datenpflege = int_Datenpflege + 1
                   ThisWorkbook.Sheets("Datenpflege").Range("F" & int_Datenpflege) = strOrdner_Custom_neu
                   boolOrdner_anlegen = False
               End If
               Call Firma_auswaehlen
           End If
       End If
   End If
End If
int_i = int_i + 1
Wend
End Sub

Private Sub Formeln_in_R1()
Dim strFormel_Sp_i As String
Dim strFormel_Sp_j As String
Dim strFormel_Sp_k As String
Dim Ende As Long
Ende = Cells(Rows.Count, 1).End(xlUp).Row

strFormel_Sp_i = "=WENNFEHLER(INDEX(Projekt!A:A;VERGLEICH(""*""&A3&""*"";Projekt!$A:$A;));"""")"
strFormel_Sp_j = "=INDEX(Firmen!$A:$A;VERGLEICH(D:D;Firmen!$B:$B;))"
strFormel_Sp_k = "=SUCHEN($K$1;H:H)"

With ThisWorkbook.Sheets("R1 - Projekte")
'With ThisWorkbook.Sheets("R2") war test
   .Range("K1") = ThisWorkbook.Sheets("Datenpflege").Range("B2")
   .Range("I2") = "angelegt"
   .Range("J2") = "Ordner_custom"
   .Range("E1").FormulaLocal = "=""Anzahl = ""&TEILERGEBNIS(3;A3:A1000)"
   .Range("I3:I" & Ende).FormulaLocal = strFormel_Sp_i
   .Range("J3:J" & Ende).FormulaLocal = strFormel_Sp_j
   .Range("K3:K" & Ende).FormulaLocal = strFormel_Sp_k
End With
End Sub

Sub Start_Alles()
ThisWorkbook.Sheets("Datenpflege").Visible = True
ThisWorkbook.Sheets("Firmen").Visible = False
ThisWorkbook.Sheets("Projekt").Visible = False
ThisWorkbook.Sheets("Datenpflege").Columns(6).Clear
On Error Resume Next
ThisWorkbook.Sheets("R1 - Projekte").ShowAllData
On Error GoTo 0
strLaufW = ThisWorkbook.Sheets("Datenpflege").Range("B5")

'Formeln in Tabelle "R1 - Projekte"
Call Formeln_in_R1
'Firmen aus Laufwerk K:\ holen
Call Firmen_einlesen
'Projekte zu Firmen aus Laufwerk K:\ holen
Call Projektname_einlesen
'Ordnerstruktur bearbeiten
Call Firma_anlegen
With ThisWorkbook.Sheets("R1 - Projekte")
   .Activate
   .Range("A2").Select
End With
ThisWorkbook.Sheets("Datenpflege").Range("B6") = "L = " & Now()
ThisWorkbook.Sheets("Datenpflege").Visible = True
ThisWorkbook.Save

MsgBox "Habe Fertig"
End Sub
Edit:
noch ein paar Bilder zum verständnis

ZimmerMichl

27.04.2018, 07:11
Danke für die Antwort,

das ganze ist mir dann wohl doch ein paar Stockwerke zu hoch.

Kuwer

27.04.2018, 09:25
Hallo,

meinst Du so?
Sub NeuerOrdner()

  Dim strK As String

  Dim strN As String

  Dim strV As String

  With Worksheets("Daten").Cells(Rows.Count, 5).End(xlUp).EntireRow

    strK = "C:\Desktop\Kunde\" & .Cells(1, 5).Value & "\"

    strV = strK & "Vorlage"

    strN = strK & .Cells(1, 2).Value & "_" & .Cells(1, 3).Value

  End With

  Shell "xcopy /E/I/S/Y " & strV & " " & strN, vbHide

End Sub
Gruß Uwe
Clever-Excel-Forum > Office-Anwendungen > Excel > VBA Ordner suchen und kopieren