Kopieren von Bereichen mit vorgegebener Liste

Hallo Zusammen,
zuerst möchte ich mich dafür entschuldigen, dass ich manchmal nicht sofort auf eure Vorschläge reagiere, da ich öfters unterwegs bin und dann kein Internetanschluss habe. Ich bemühe mich jedoch, jedem der einen Beitrag schreibt, einer Antwort zu schreiben, ob dass Ganze funktioniert hat bzw. einfach um sich zu bedanken. Danke nochmal an Alle für die tolle Unterstützung ;)
Jetzt habe ich folgendes Anliegen (eigentlich dass komplizierteste aller meiner bisherigen Fragen):
Ich habe eine Arbeitsmappe mit einem Bereich A1:G100 in Tabelle1, der mit Formeln unterlegt ist. In A1 steht der Dateiname auf der der Bereich zugreift, um sich die Daten zu holen.
Im zweiten Tabellenblatt steht in A1:A100 eine Liste an Dateinamen, die sich ändern kann. In der Liste stehen zwischen 1 und 100 Einträge.
Ich würde gerne einen Makro haben, der zuerst die Liste in Tabelle 2 durchgeht um die Anzahl der Dateinamen festzustellen (in der Beispieldatei: 27)
Im zweiten Schritt soll dieser Makro den Bereich A1:G100 in der Tabelle 1 nach unten kopieren, und zwar für jeden Dateiname aus der Liste Tabelle 2 soll ein Bereich dann vorhanden sein (In Tabelle1: Bestehender Bereich + 26 kopierte Bereiche = 27 Bereiche untereinander)
Im dritten Schritt soll der Makro in jedem Bereich der Dateiname in der ersten obersten linken Zelle des Bereichs einfügen (also Tabelle2 A1 in Tabelle1 A1, Tabelle2 A2 in Tabelle1 A101 usw.) so dass die Formeln sich automatisch ändern und dann aus der entsprechenden Datei die Daten rausliesst.
Anschliessend alle Zeile 1:10000 kopieren: Werte einfügen.
Weiter sollen alle Zeilen in Tabelle 1 gelöscht werden falls in Spalte G Zelle ="" oder Zelle="Rückstellung")
Datei: https://www.herber.de/bbs/user/41262.xls
Danke
Salim

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Salim,
hier mein Lösungsvorschlag
Die Namen der Tabellen im Code muss du ggf. anpassen.
Gruß
Franz

Sub Test()
Dim wksDateien As Worksheet, wksFormeln As Worksheet
Dim rngFormeln As Range, AnzahlDateien As Integer, Datei As Integer
Dim Zeilen As Long, Zeile As Long
Set wksFormeln = Worksheets("Tabelle1")
Set wksDateien = Worksheets("Tabelle2")
Set rngFormeln = wksFormeln.Range("A1:G100")
Zeilen = rngFormeln.Rows.Count 'Anzahl Zeilen im Formelblock
'Anzahl Dateien
With wksDateien
AnzahlDateien = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte ausgefüllte Zeile in Spalte A
End With
Application.Calculation = xlCalculationManual 'Formelberechnung manuel
Application.ScreenUpdating = False
With wksFormeln
'Formelbereich kopieren
For Datei = 1 To AnzahlDateien - 1
rngFormeln.Copy Destination:=.Cells(Datei * Zeilen + 1, 1)
Next
'Dateinamen eintragen
For Datei = 1 To AnzahlDateien
.Cells((Datei - 1) * Zeilen + 1, 1).Value = wksDateien.Cells(Datei, 1).Value
Next
Application.Calculation = xlCalculationAutomatic 'Formelberechnung automatisch
.Calculate
'Formeln durch Werte ersetzen
.Range(.Cells(1, 1), .Cells(AnzahlDateien * Zeilen, 7)).Value _
= .Range(.Cells(1, 1), .Cells(AnzahlDateien * Zeilen, 7)).Value
'Zeilen prüfen in Spalte G, ggf. Zeile löschen
Application.Calculation = xlCalculationManual 'Formelberechnung manuel
For Zeile = AnzahlDateien * Zeilen To 1 Step -1
Application.StatusBar = "Prüfe Zeile " & Zeile
If .Cells(Zeile, 7).Value = "" Or .Cells(Zeile, 7).Value = "Rückstellung" Then
.Rows(Zeile).Delete shift:=xlShiftUp
End If
Next
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic 'Formelberechnung automatisch
.Activate
.Cells(1, 1).Select
End With
Application.ScreenUpdating = True
MsgBox "Fertig!"
End Sub

Beliebteste Forumthreads (12 Monate)

Kopieren von Bereichen mit vorgegebener Liste

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread