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.
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.
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.
26.04.2018, 14:02 (Dieser Beitrag wurde zuletzt bearbeitet: 26.04.2018, 14:15 von Wastl.)
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
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
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
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
'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
' 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
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
