Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
272to276
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
272to276
272to276
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Ordner kopieren und umbenennen

Ordner kopieren und umbenennen
29.06.2003 20:43:23
Tobias

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Ordner kopieren und umbenennen
29.06.2003 21:19:44
Marcus
Jetzt sieht man auch die Frage ...
Marcus

AW: Ordner kopieren und umbenennen
29.06.2003 21:44:56
Nepumuk
Hallo Tobias,
so sollte es funktionieren:
Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Function GetAOrdner() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim(FolderName)
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
GetAOrdner = FolderName
End Function
Public Sub umbenennen()
Dim FsyObjekt As Object, FolObjekt As Object, FilObjekt As Object
Dim Ordner As String, index As Integer, Tabelle As Worksheet, Neu As String
Ordner = GetAOrdner
If Ordner <> "" Then
Application.ScreenUpdating = False
Neu = Cells(1, 1)
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
Set FolObjekt = FsyObjekt.GetFolder(Ordner)
Ordner = Left(Ordner, Len(Ordner) - Len(Neu)) & Neu
FolObjekt.Copy (Ordner)
With Application.FileSearch
.LookIn = Ordner
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 1 Then
For index = 1 To .FoundFiles.Count
If ThisWorkbook.FullName <> .FoundFiles(index) Then
Workbooks.Open .FoundFiles(index)
For Each Tabelle In ActiveWorkbook.Sheets
Tabelle.Name = Left(Tabelle.Name, Len(Tabelle.Name) - Len(Neu)) & Neu
Next
ActiveWorkbook.Close True
Set FilObjekt = FsyObjekt.GetFile(.FoundFiles(index))
FilObjekt.Name = Left(FilObjekt.Name, Len(FilObjekt.Name) - Len(Neu) - 4) & Neu & ".xls"
End If
Next
End If
End With
For Each Tabelle In ThisWorkbook.Worksheets
Tabelle.Name = Left(Tabelle.Name, Len(Tabelle.Name) - Len(Neu)) & Neu
Next
ThisWorkbook.SaveAs Ordner & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - Len(Neu) - 4) & Neu & ".xls"
Application.ScreenUpdating = True
End If
End Sub
Gruß
Nepumuk

Anzeige
AW: Ordner kopieren und umbenennen
30.06.2003 17:31:10
Tobias
Hallo Nepumuk
vielen Dank für deine Hilfe, werde es heut Abend noch testen
Gruß Tobias

AW: Ordner kopieren und umbenennen
30.06.2003 20:45:55
Nepumuk
Hallo Tobias,
da war noch ein grober Fehler drin. Aber jetzt geht's:

Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Function GetAOrdner() As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
.Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim(FolderName)
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
GetAOrdner = FolderName
End Function
Public Sub umbenennen()
Dim FsyObjekt As Object, FolObjekt As Object, FilObjekt As Object
Dim Ordner As String, index As Integer, Tabelle As Worksheet, Neu As String
Dim xlApp As New Excel.Application
Ordner = GetAOrdner
If Ordner <> "" Then
Application.ScreenUpdating = False
Neu = Cells(1, 1)
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
Set FolObjekt = FsyObjekt.GetFolder(Ordner)
Ordner = Left(Ordner, Len(Ordner) - Len(Neu)) & Neu
FolObjekt.Copy (Ordner)
With Application.FileSearch
.LookIn = Ordner
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 1 Then
For index = 1 To .FoundFiles.Count
If ThisWorkbook.FullName <> .FoundFiles(index) Then
xlApp.Workbooks.Open .FoundFiles(index)
For Each Tabelle In xlApp.ActiveWorkbook.Sheets
Tabelle.Name = Left(Tabelle.Name, Len(Tabelle.Name) - Len(Neu)) & Neu
Next
xlApp.ActiveWorkbook.Close True
Set FilObjekt = FsyObjekt.GetFile(.FoundFiles(index))
FilObjekt.Name = Left(FilObjekt.Name, Len(FilObjekt.Name) - Len(Neu) - 4) & Neu & ".xls"
End If
Next
End If
End With
Application.ScreenUpdating = True
End If
End Sub


Gruß
Nepumuk

Anzeige
AW: Ordner kopieren und umbenennen
30.06.2003 20:52:03
Nepumuk
Hallo Tobias,
da lassen sich sogar noc zwei Zeilen sparen.
With Application.FileSearch
.LookIn = Ordner
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 1 Then
For index = 1 To .FoundFiles.Count
xlApp.Workbooks.Open .FoundFiles(index)
For Each Tabelle In xlApp.ActiveWorkbook.Sheets
Tabelle.Name = Left(Tabelle.Name, Len(Tabelle.Name) - Len(Neu)) & Neu
Next
xlApp.ActiveWorkbook.Close True
Set FilObjekt = FsyObjekt.GetFile(.FoundFiles(index))
FilObjekt.Name = Left(FilObjekt.Name, Len(FilObjekt.Name) - Len(Neu) - 4) & Neu & ".xls"
Next
End If
End With
Gruß
Nepumuk

Anzeige
AW: Ordner kopieren und umbenennen
01.07.2003 12:57:21
Tobias
Hallo Nepumuk
hab mich wohl etwas undeutlich ausgedrückt.
Ich habe einen Ordner "Imkerbuch" in dem befinden sich weitere 2Ordner ("Eigenschaften", "Jahr0000") und eine Excelmappe. Diese Excelmappe enthält eine Buttenzentrale die auf den Ordner "Jahr0000" verweist. Wenn in Zelle H11 eine Jahreszahl (z.B."2003") eingegeben wird und es denn Ordner "Jahr2003" noch nicht gibt, soll der Ordner "Jahr0000" kopiert und entsprechend umbenannt werden. Die Excelmappen in diesem Ordner ("Stand10000", "Stockkarte10000", usw.) sollen auch nach der Jahreszahl umbenannt werden (also "Stand12003", "Stockkarte12003", usw.)
ist das machbar??
Gruß Tobias

Anzeige
AW: Ordner kopieren und umbenennen
01.07.2003 18:32:48
Nepumuk
Hallo Tobias,
was ist bitte eine Buttenzentrale? In welcher Mappe wird in H11 die Jahreszahl eingetragen? Sollen die Tabellenblätter auch umbenannt werden, wie in deiner ersten Anfrage gewünscht?
Gruß
Nepumuk

AW: Ordner kopieren und umbenennen
01.07.2003 21:53:43
Tobias
Hallo Nepumuk
Buttenzentrale = Tabbellenblatt mit Butten die auf den Ordner "Jahr0000" verweisen. Die Jahreszahl wird in dem Tabellenblatt mit den Butten eingegeben. Ach so, ja die Tabellenblätter auch.
Gruß Tobias

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige