Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1360to1364
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
Inhaltsverzeichnis

Tabellenblätter kopieren mit Hürden

Tabellenblätter kopieren mit Hürden
23.05.2014 10:22:48
Michael
Hallo und guten Tag liebe Forumgemeinde.
Ich bin prinzipiell ein VBA Anfänger und meine Fähigkeiten beschränken sich auf Codeschnippsel zusammenkopieren und diese dann nach meinen Vorstellungen etwas abzuändern.
Die wollte ich diesmal wieder tun und habe leider ein für mich unlösbares Problem bei einem "Do-While Loop mit For Each Schleife".
Folgende Aufgabenstellung:
Ich möchte aus einem per Application.FileDialog ausgewählten Ordner, aus allen xlsm Dateien, alle Tabellenblattinhalte (Werte) in eine neue Arbeitsmappe kopieren.
Es handelt sich um ca. 25 Arbeitsmappen, mit jeweils 2-5 Tabellenblättern.
Zusätzliches Problem: Ich bekomme diese Arbeitsmappen. Diese sind schreibgeschützt und soweit es für mich ausschaut nur per Usereingabe ansteuerbar (UserInterfaceOnly=True). Dies kann ich aber nicht bestätigen, da auch die Makros per Passwort gesichert sind....(kann das sein oder hab ich bei meinen vorherigen Kopierversuchen total versagt?!?!)
Jetzt zu meiner aktuellen Lösung:

Sub Tabellenblätterkopieren()
Dim wb As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Dim Blattname As String
Set wb = ActiveWorkbook
On Error Resume Next
Dim Speicherplatz As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "\\Tralala\Herber\Forum"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
Speicherplatz = .SelectedItems(1)
If Right(Speicherplatz, 1)  "\" Then Speicherplatz = Speicherplatz & "\"
Else
Speicherplatz = ""
End If
End With
If Speicherplatz = "" Then MsgBox ("Kein Ordner gewählt!") Else
xlApp.Application.EnableEvents = False
Application.DisplayAlerts = False
Auslesedateien = Dir(Speicherplatz & "\" & "*.xls*")
Do While Auslesedateien  ""
Workbooks.Open (Speicherplatz & Auslesedateien), ReadOnly:=True, UpdateLinks:=0
For Each sh In wb.Worksheets
Cells.Select
Range("B1").Activate
Selection.Copy
With wb.Worksheets
Set shNew = .Item(sh.Name)
.Add after:=.Item(.Count)
.Item(.Count).Name = sh.Name
Set shNew = .Item(.Count)
With shNew.Range("A1:Z300")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlFormats
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteValues
End With
End With
Next sh
Workbooks(Auslesedateien).Close savechanges:=False
Auslesedateien = Dir()
Loop
xlApp.Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Derzeit funktioniert folgendes:
Auswählen des Ordners,
Öffnen aller Dateien in diesem Ordner die ein xlsm am Ende stehen haben,
Kopieren des jeweils ersten Tabellenblattes der Dateien,
Was derzeit mindestens fehlt:
Kopieren der restlichen Tabellenblätter der jeweiligen Dateien,
Umbenennen der Tabellenblätter (im besten Fall eindeutig wie z.b. ersten beiden Zeichen des Mappennamens & Tabellenname)
Nebeninfos:
    Cells.Select
Range("B1").Activate
Selection.Copy

Diesen Teil verwende ich, weil dies glaub ich trotz userinterfaceonly Funktion das kopieren erlaubt ?!?! (Bitte korrigieren, wenn falsch)
Ich weiß, dass es schon einige Themen im Internet gibt, die sich mit Tabellenblatt kopieren beschäftigen, aber die behandeln stets nur ein Tabellenblatt pro zu kopierender Mappe (for each Problem daher nicht enthalten) oder sind zu verwirrend geschrieben, als das ich sie verstehen könnte...
Ich danke euch schon im Voraus fürs lesen des Beitrags und hoffe auf Hilfe.
Jeder kleine Hinweis wird dankend angenommen!
Liebe Grüße,
MB

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenblätter kopieren mit Hürden
23.05.2014 11:08:27
Rudi
Hallo,
teste mal:
Sub Tabellenblaetterkopieren()
Dim wbAkt As Workbook
Dim wb As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Dim SpeicherPlatz As String, AusleseDatei As String
Set wb = ActiveWorkbook
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "\\Tralala\Herber\Forum"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
SpeicherPlatz = .SelectedItems(1)
Else
SpeicherPlatz = ""
End If
End With
If SpeicherPlatz = "" Then
MsgBox ("Kein Ordner gewählt!")
Else
If Right(SpeicherPlatz, 1)  "\" Then SpeicherPlatz = SpeicherPlatz & "\"
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With
AusleseDatei = Dir(SpeicherPlatz & "*.xlsm")
Do While AusleseDatei  ""
Set wb = Workbooks.Open(SpeicherPlatz & AusleseDatei, ReadOnly:=True, UpdateLinks:=0)
For Each sh In wb.Worksheets
With wbAkt
Set shNew = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
shNew.Name = sh.Name
End With
sh.Cells.Copy
With shNew.Range("A1:Z300")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlFormats
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteValues
End With
Next sh
wb.Close False
AusleseDatei = Dir()
Loop
End If
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub

Gruß
Rudi

Anzeige
AW: Tabellenblätter kopieren mit Hürden
23.05.2014 15:27:19
Michael
Hallo alle!
Großer Dank an dich Rudi.
Ich musste nur am Anfang des Codes " Set wb = ActiveWorkbook" in "Set wbAkt = ActiveWorkbook" ändern, damit der Code funktioniert.
Da ich vollkommen übersehen habe, dass es sehr viele (unnötige) unsichtbare Tabellenblätter gibt, habe ich eine kleine If Abfrage eingebaut.
Ein Problem habe ich jedoch noch bei dem tollen Code von dir (danke nochmal):
Nur bei der ersten zu kopierenden Arbeitsmappe schafft das Script alle Tabellenblattnamen zu übernehmen. Für jede weitere Arbeitsmappe gilt: die ersten beiden kopierten Tabellenblätter werden nicht umbenannt, die restlichen "x" schon.
Ich kann jedoch in dem Code den Fehler dazu nicht finden ?!!?
Der Code sieht jetzt übrigens so aus:
Sub Tabellenblaetterkopieren()
Dim wbAkt As Workbook
Dim wb As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Dim SpeicherPlatz As String, AusleseDatei As String
Set wbAkt = ActiveWorkbook ' Wie beschrieben, habe ich hier wb in wbAKT geändert
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "Z:\Y\X\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
SpeicherPlatz = .SelectedItems(1)
Else
SpeicherPlatz = ""
End If
End With
If SpeicherPlatz = "" Then
MsgBox ("Kein Ordner gewählt!")
Else
If Right(SpeicherPlatz, 1)  "\" Then SpeicherPlatz = SpeicherPlatz & "\"
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With
AusleseDatei = Dir(SpeicherPlatz & "*.xlsm")
Do While AusleseDatei  ""
Set wb = Workbooks.Open(SpeicherPlatz & AusleseDatei, ReadOnly:=True, UpdateLinks:=0)
For Each sh In wb.Worksheets
If sh.Visible = xlSheetVisible Then ' IF eingeführt um nur sichtbare
Tabellenblätter zu kopieren
With wbAkt
Set shNew = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
shNew.Name = sh.Name
End With
sh.Cells.Copy
With shNew.Range("A1:Z300")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlFormats
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteValues
End With
End If
Next sh
wb.Close False
AusleseDatei = Dir()
Loop
End If
With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Wäre es vielleicht, um dieses Script perfekt zu machen noch möglich (wie im Ursprungsbeitrag beschrieben), die Tabellenblattnamen noch mit den ersten 2 Zeichen des Arbeitsmappennames zu versehen ?
Bei dieser Namen in einen String speichern und an anderer Stelle richtig einfügen, bin ich leider total verloren.
Ich möchte mich nochmal herzlichst für die Hilfe bedanken! Danke!
LG,
MB
Anzeige

312 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige