Konsolidierung & Dropdowns
12.09.2022 03:32:04
Kisska
ich habe einen VBA-Code gefunden, mit den man mehrere Dateien mit allen darin enthaltenen Tabellenblättern konsolidiert.
Leider werden die Dropdowns nicht übernommen. Wenn man auf die Datenüberprüfung geht, dann sieht man, dass der Bezug gelöscht wurde:
"='\\Netzwerkname\[Dateiname.xlsx]Daten'!#BEZUG!".
Ist es möglich, die Dropdowns zu behalten? Es wäre gut, wenn der Bezug direkt so heißen würde: "=Daten!XY"
Zur Info: Der Aufbau aller Dateien ist gleich, es gibt insgesamt drei Tabellenblätter, im ersten Blatt "Ergebnis" stehen die Dropdowns, im zweiten Blatt "Daten" befinden sich die Listen für die Dropdowns und im dritten Blatt stehen Hinweise. Die Tabellenblätter "Daten" und "Hinweise" sind in allen Dateien inhaltsgleich. Eigentlich brauche ich bei der Konsolidierung diese nur 1 Mal. Daher die zweite Frage: Wenn die Übernahme von Dropdowns doch möglich ist, ist es zudem möglich, dass das Tabellenblatt "Daten" mit den Listen für die Dropdowns und das Tabellenblatt "Hinweise" nur ein Mal in der konsolidierten Datei stehen?
Hier ist der Code:
Sub Dateien_zusammenfuehren()
'Führt alle Tabellenblätter der ausgewählten Excel-Dateien in dieser Arbeitsmappe zusammen
Dim wbQuelle As Workbook
Dim sh As Worksheet
Dim arrdateien As Variant
Dim cntDatei As Long
'Screenupdating deaktivieren
Application.ScreenUpdating = False
'Benutzer Dateien auswählen lassen
arrdateien = Application.GetOpenFilename(filefilter:="Excel-Dateien (*.xlsx),*.xlsx", MultiSelect:=True)
'Wurde mindestens eine Datei ausgewählt?
If IsArray(arrdateien) Then
'Schleife über alle ausgewählten Dateien
For cntDatei = 1 To UBound(arrdateien)
'Aktuelle Arbeitsmappe öffnen
Set wbQuelle = Workbooks.Open(Filename:=arrdateien(cntDatei), UpdateLinks:=False, ReadOnly:=True)
'Schleife über alle Tabellenblätter
For Each sh In wbQuelle.Worksheets
'Aktuelles Tabellenblatt kopieren
sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next sh
'Aktuelle Arbeitsmappe schließen
wbQuelle.Close savechanges:=False
Next cntDatei
End If
'Screenupdating aktivieren
Application.ScreenUpdating = True
'Bereitgestellt von VBATrainer: www.vbatrainer.de
End Sub
Kisska