Dynamisches Kopieren mit VBA

Guten Abend zusammen,
ich versuche derzeit aus diversen Quelltabellenblättern (einheitliches Format) eine zeilen- und spaltenweise Zuordnung in einem
Zieltabellenblatt vorzunehmen.
Über statische Zellbezüge habe ich dies auch schon hinbekommen. Da sich im Zielbereich jedoch Zeilen und Spalten verschieben
können, muss das Makro dynamisch sein.
Bisher versucht habe ich folgendes:
1) Formellösung (Matrixformeln mit indirekt) -->Rechner ging in die Knie, da mehr als 20.000 Zeilen beansprucht werden
2) VBA-Lösung mit fixen Zeilen- und Spaltenbezügen -->deutlich schneller, jedoch nicht praktikabel (wegen möglicher Verschiebungen).
Leider sind meine VBA-Kenntnisse nicht ausreichend, um das Vorhaben dynamisch zu gestalten, daher habe ich eine Beispielmappe
erstellt und hoffe, dass sich jemand findet, der mir diesbezüglich helfen kann.
Vielen Dank.
Herzliche Grüße
silverchair
Ich habe hier eine Beispielmappe hochgeladen:

https://www.herber.de/bbs/user/125118.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim dicErg As Object Dim dicDat As Object Dim z As Long, s As Long Dim arrDat, dat Dim rng As Range Dim arr Dim ID Dim erg Dim sh As Worksheet Set dicErg = CreateObject("Scripting.dictionary") '--- Datumswerte einlesen With Sheets("Ziel") arrDat = Range(.Cells(2, 9), .Cells(2, 9).End(xlToRight)).Value End With '--- Daten aus TAbellenblättern lesen For Each sh In ThisWorkbook.Worksheets If sh.Name "Ziel" Then arr = sh.UsedRange.Value For s = 1 To UBound(arr, 2) Step 9 For z = 3 To UBound(arr, 1) If arr(z, s) = "" Then Exit For ID = sh.Name & "_" & arr(z, s) If dicErg.exists(ID) Then Set dicDat = dicErg(ID) Else Set dicDat = CreateObject("Scripting.dictionary") For Each dat In arrDat dicDat(Replace(dat, " ", "_")) = "" Next End If dicDat(arr(1, s + 6)) = arr(z, s + 6) dicDat(arr(1, s + 7)) = arr(z, s + 7) Set dicErg(ID) = dicDat Next Next End If Next '--- Ergebnis schreiben ReDim erg(1 To dicErg.Count, 1 To 7 + UBound(arrDat, 2)) z = 0 For Each ID In dicErg.keys z = z + 1 erg(z, 1) = Split(ID)(0) erg(z, 2) = Mid(ID, InStr(ID, "_") + 1) For s = 3 To 7 erg(z, s) = Split(ID, "_")(s - 1) Next Set dicDat = dicErg(ID) For s = 1 To UBound(arrDat, 2) erg(z, 7 + s) = dicDat(Replace(arrDat(1, s), " ", "_")) Next Next Sheets("Ziel").Cells(12, 2).Resize(UBound(erg, 1), UBound(erg, 2)) = erg End Sub

Hallo
hier eine Lösung von mir

Option Explicit

Sub QuellCopy()
    On Error GoTo Fehler
    Dim TB1, TB, i As Integer, StartZ As Double
    Dim Z1 As Integer, LC As Integer, LR As Double
    Dim SpQ As Integer, ZQ1 As Integer, QSp As Integer
    
    Set TB1 = Sheets("Ziel")
    Z1 = 2 'Zeile mit Keys 
    SpQ = 2 'Spalte mit Quellinfo 
    ZQ1 = 3 'Zeile1 in Quelle 
    LC = TB1.Cells(Z1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile 

    For Each TB In ActiveWorkbook.Sheets
        If TB.Name <> TB1.Name Then 'Jedes Blatt ausser das Erste 
            On Error Resume Next
            StartZ = WorksheetFunction.Match(TB.Name, TB1.Columns(SpQ), 0) + 1 'Finder der ZielZeile nach Blattname 
            On Error GoTo Fehler
            If StartZ > 0 Then
                LR = TB.Cells(TB.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 
                
                For i = SpQ + 1 To LC
                    On Error Resume Next
                    QSp = WorksheetFunction.Match(TB1.Cells(Z1, i), TB.Rows(1), 0) 'Spalte des Keywords finden 
                    On Error GoTo Fehler
                    If QSp > 0 Then
                        
                        'Werte von Quelle nach Ziel übertragen 
                        TB1.Cells(StartZ, i).Resize(LR - ZQ1 + 1).Value = _
                            TB.Cells(ZQ1, QSp).Resize(LR - ZQ1 + 1).Value
                        QSp = 0
                    End If
                Next
                
            End If
            StartZ = 0
        End If
    Next
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Achtung die Formeln habe ich abgeändert

Ziel

GW_Januar_2018

IW_Januar_2018

GW_Februar_2018

IW_Februar_2018

GW_März_2018

IW_März_2018

GW_April_2018

IW_April_2018

GW_Mai_2018

IW_Mai_2018

GW_Juni_2018

IW_Juni_2018

verwendete Formeln
Zelle	Formel	Bereich	N/A
I2,K2,M2,O2,Q2,S2	="GW_"&TEXT(I$1;"MMMM")&"_"&TEXT(I$1;"JJJJ")
J2,L2,N2,P2,R2,T2	="IW_"&TEXT(J$1;"MMMM")&"_"&TEXT(J$1;"JJJJ")

http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip

http://Hajo-Excel.de/tools.htm

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 25.14 einschl. 64 Bit

LG UweD

Beliebteste Forumthreads (12 Monate)

48
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dynamisches Kopieren mit VBA

48 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

48
Beiträge zum Forumthread

Beiträge zu diesem Forumthread