VBA Schleife schreiben - Essenswahl

Hallo liebe Profis,
ich bin verzweifelt und hoffe auf eure Unterstützung.
Mein Problem stellt sich wie folgt dar:
Im 'Tabellenblatt4' möchte ich aus den Spalten 'F' bis 'BJ' immer dann den Zelleintrag aus Spalte 'D' auf dem 'Tabellenblatt5' eintragen lassen, wenn in der entsprechenden Zeile von 'F', 'G', 'H' usw. ein Wert größer 0 steht. Für eine Spalte bekomme ich auch schon eine Schleife hin, die mir das für wie gewünscht liefert (siehe unten). Leider fehlt mir die Kenntnis, wie ich die Schleife nun so erweitere, dass nach Spalte 'F' automatisch alle weiteren Spalten - bis BJ - ebenso in das entspreche (Ziel-)Tabellenblatt kopiert werden.
Ich hoffe, ich konnte mein Problem einigermaßen verständlich erklären.
Vielen Dank für eure Hilfe und mit freundlichen Grüßen
Marcel
Hier das Tabellenblatt aus dem die Werte entnommen werden sollen:
Userbild

Hier das Tabellenblatt in das die Werte eingefügt werden sollen:
Userbild

Hier der Code, der zumindest für die erste Spalte funktioniert:
Userbild

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
ersetzen den Code durch diesen.

Sub TEST()
Dim ArData, ArSpeisen, NewAr()
Dim MaxRow&, MaxCol&
Dim oDic As Object

On Error GoTo ErrorHandler:

Set oDic = CreateObject("Scripting.Dictionary")

With Tabelle4
    MaxRow = .Cells(.Rows.Count, 4).End(xlUp).Row
    MaxCol = .Range("BJ1").Column
    ArData = .Range("F3", .Cells(MaxRow, MaxCol))
    ArSpeisen = .Range("D3", .Cells(MaxRow, 4))
End With

Application.ScreenUpdating = False
Application.EnableEvents = False

With Tabelle5
    .UsedRange.EntireRow.Delete
    For nn = Lbound(ArData, 2) To Ubound(ArData, 2)
        For n = Lbound(ArData) + 1 To Ubound(ArData)
            If ArData(n, nn) > 0 Then
                If ArSpeisen(n, 1) <> "" Then
                    oDic(ArSpeisen(n, 1)) = oDic(ArSpeisen(n, 1)) + ArData(n, nn)
                End If
            End If
        Next n
        oDic("") = ""
        If oDic.Count > 0 Then
            NewAr = TransposeDic(oDic)
            MaxCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
            If MaxCol > 1 Then MaxCol = MaxCol + 1
            
            With .Cells(3, MaxCol).Resize(Ubound(NewAr), Ubound(NewAr, 2))
                .Cells(1, 1).Offset(-2, 0).Value = ArData(1, nn)
                .Cells(1, 1).Offset(-2, 0).NumberFormat = "yyyy/mm/dd"
                .Cells(1, 1).Offset(-1, 0).Value = "Gereicht"
                .Cells(1, 2).Offset(-1, 0).Value = "Bezahlt"
                .Value = NewAr
                .WrapText = False
                Erase NewAr
            End With
        End If
        oDic.RemoveAll
    Next nn
    With .UsedRange
        For n = 2 To .Columns.Count Step 2
            .Columns(n).Borders(xlEdgeRight).Weight = xlThin
        Next
    End With
    .UsedRange.EntireColumn.AutoFit
End With

ErrorHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True

If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number
End If
End Sub

Function TransposeDic(oDic As Object)
Dim NewArray(), n&, nn&
Dim tmpAr
Redim Preserve NewArray(1 To oDic.Count, 1 To 2)
tmpAr = oDic.keys
For n = Lbound(tmpAr) To Ubound(tmpAr)
    nn = nn + 1
    NewArray(nn, 1) = tmpAr(n)
    NewArray(nn, 2) = oDic(tmpAr(n))
Next
TransposeDic = NewArray
End Function

Gruß Tino

For Spalte = 0 To SpalteMax - 1 i = 3 'immer zurücksetzen !! For Zeile = 4 To ZeileMax If .Cells(Zeile, 6 + Spalte) > 0 Then .Cells(Zeile, 4 + Spalte).Copy Destination .... i = i + 1 Next Zeile Next Spalte

Beliebteste Forumthreads (12 Monate)

VBA Schleife schreiben - Essenswahl

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread