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, 13:02 (Dieser Beitrag wurde zuletzt bearbeitet: 26.04.2018, 13: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