AW: Daten kopieren aus verschied Spalten aus Tabellen
20.02.2016 13:19:09
Mamo
Hallo,
ich habe im Forum ein VBA-Code gefunden. Man kan mit dem Code aus mehreren Dateien und Tabellen Daten in eine anderen Datei kopieren.
Wie kann man das so änderen, dass man für jede Datei im Verzeichnis aus allen sheets den benutzten Bereich in einer neuen Tabelle kopieren und die Tabelle nach dem Quelldatei benennen.
Sub Zusammenführen_in_eine_Tabelle(Verzeichnis As String)
' Führt die Tabellen aus den Dateien in Verzeichnis in einer Datei zusammen
' Dabei werden die Daten aus den Tabellen der Quell-Dateien in eine oder mehr Ziel-Tabelle(n) _
_
_
kopiert
' Dabei werden in den Tabellen alle Formeln in Werte verwandelt
Dim wbQuelle As Workbook, wksQuelle As Worksheet, wbZiel As Workbook, wksZiel As Worksheet
Dim Datei As String, ZeileDaten As Long, Zeile As Long, wksListe As Worksheet
Dim Spaltenformat As Boolean, I As Integer, Blatt As Integer
'Neue Datei zum Zusammenführen der Tabellen Dateien anlegen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksZiel = wbZiel.Sheets(1)
Blatt = 1 'Zählnummer für Blätter mit Daten
wksZiel.Name = "Tabelle" & Blatt
wbZiel.Worksheets.Add After:=Sheets(1) 'Blatt das die zusammengefassten Tabellen _
protokolliert
Set wksListe = ActiveSheet
wksListe.Name = "Importprotokoll"
Zeile = 1
wksListe.Cells(Zeile, 1) = "Import-Protokoll"
Zeile = 2
wksListe.Cells(Zeile, 1) = "Quell-Datei"
wksListe.Cells(Zeile, 2) = "Quell-Tabelle"
wksListe.Cells(Zeile, 3) = "eingefügt in Blatt"
ZeileDaten = 1
Application.ScreenUpdating = False
'Exceldateien im Verzeichnis Öffnen
Datei = Dir(Verzeichnis & "*.xls")
Spaltenformat = False
Do Until Datei = ""
Application.StatusBar = "Die " & Zeile - 1 & ". Datei wird bearbeitet, Dateiname: " & _
Datei
Set wbQuelle = Workbooks.Open(FileName:=Verzeichnis & Datei, ReadOnly:=True)
For Each wksQuelle In wbQuelle.Worksheets 'Variante für alle Tabellenblätter
With wksQuelle
If ZeileDaten + .UsedRange.Rows.Count > wksZiel.Rows.Count Then
Blatt = Blatt + 1
wbZiel.Worksheets.Add After:=Sheets(Blatt - 2) 'weiteres Blatt für Daten
Set wksZiel = wbZiel.Sheets(Blatt)
wksZiel.Name = "Tabelle" & Blatt
Spaltenformat = False
ZeileDaten = 1
End If
If Spaltenformat = False Then
'Aus der 1. Tabelle der nächsten, Datei werden die Spaltenbreiten ausgelesen und in _
die Ziel-Tabelle übertragen
For I = 1 To .UsedRange.Column + .UsedRange.Columns.Count - 1
wksZiel.Columns(I).ColumnWidth = .Columns(I).ColumnWidth
Next I
Spaltenformat = True
End If
Zeile = Zeile + 1
wksListe.Cells(Zeile, 1) = wbQuelle.FullName
wksListe.Cells(Zeile, 2) = wksQuelle.Name
wksListe.Cells(Zeile, 3) = Blatt
'Formeln durch Werte ersetzen
.UsedRange.Copy
.Range(.UsedRange.Address).PasteSpecial Paste:=xlPasteValues
.UsedRange.EntireRow.Copy Destination:=wksZiel.Cells(ZeileDaten, 1)
ZeileDaten = ZeileDaten + .UsedRange.Rows.Count
End With
Next wksQuelle
wbQuelle.Close Savechanges:=False
Datei = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
wbZiel.Activate
'Protokollliste Formatieren
wksListe.Select
wksListe.Columns("A:B").AutoFit
wksListe.Range("A3").Select
ActiveWindow.FreezePanes = True
' Datei-Speichern Dialog anzeigen
Application.Dialogs(xlDialogSaveWorkbook).Show
End Sub
Grüße