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