bestimmte Spalten mit Werten füllen

Sub Tabelle_füllen() Dim objRang As Range Set objRang = ActiveSheet.Range(Cells(2, 1), _ Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)) Application.ScreenUpdating = False With ActiveSheet For Each c In objRang If c = "a" Then .Range(Cells(c.Row, 2), Cells(c.Row, 33)).Copy _ Destination:=Worksheets("Zuordnungstabelle").Cells(Sheets(" _ Zuordnungstabelle"). _ Cells(Rows.Count, 5).End(xlUp).Row + 1, 2) End If Next End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Liste() Dim rngKrit As Range, rngListe As Range, rngAusgabe As Range Dim lngCol& Const SuchWert As String = "a" With Tabelle4 'Adresseneingabe lngCol = .Cells(1, .Columns.Count).End(xlToLeft).Column Set rngListe = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, lngCol) End With With Tabelle1 'Zuordnungstabelle Set rngAusgabe = .Range("B5", .Cells(5, .Columns.Count).End(xlToLeft)) Set rngKrit = Cells(1, .Columns.Count).Resize(2, 1) End With rngKrit(1, 1) = "Status" rngKrit(2, 1) = "'=" & SuchWert rngListe.AdvancedFilter xlFilterCopy, rngKrit, rngAusgabe rngKrit.Clear End Sub

Hallo,
diese ist aber etwas schwer zu verstehen, vielleicht kannst Du damit was anfangen.
Diese Sucht die entsprechende Überschrift in der 'Zuordnungstabelle',
ist diese nicht vorhanden, werden die Daten auch nicht geschrieben.

Sub Liste1()
Dim ArrayListe(), ArrayAusgabe(), tmpArray()
Dim lngCol&, MaxRow&, varCol
Dim A&, B&, C&

Const SuchWert As String = "a" 'Suchwert 

With Tabelle4 'Adresseneingabe 
    'Koordinaten der Tabelle suchen 
    lngCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lngCol = lngCol - 1
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    'Array größe bestimmen 
    Redim Preserve ArrayListe(lngCol)
    Redim Preserve ArrayAusgabe(lngCol)
    Redim Preserve tmpArray(lngCol)
    'Datenliste in Array schreiben, Überschrift in ArrayAusgabe 
    With .Range("A1", .Cells(MaxRow, 1))
        For A = 0 To lngCol
            ArrayListe(A) = .Offset(0, A)
            ArrayAusgabe(A) = tmpArray
            ArrayAusgabe(A)(0) = ArrayListe(A)(1, 1)
        Next A
    End With
End With

'Ausgabeliste füllen wenn Bedingung erfüllt 
For A = 2 To Ubound(ArrayListe(0))
    If ArrayListe(0)(A, 1) = SuchWert Then
        B = B + 1
        For C = Lbound(ArrayListe) To Ubound(ArrayListe)
            ArrayAusgabe(C)(B) = ArrayListe(C)(A, 1)
        Next C
    End If
Next A

With Tabelle1 'Zuordnungstabelle 
    'alte Daten löschen, eventuell anpassen ********************** 
    .Range("A6:G" & .Rows.Count).ClearContents
    '************************************************************* 
    For A = Lbound(ArrayAusgabe) To Ubound(ArrayAusgabe)
        'Spalte suchen 
        varCol = Application.Match(ArrayAusgabe(A)(0), .Rows(5), 0)
        'Spalte gefunden? 
        If IsNumeric(varCol) Then
            'Daten einfügen 
            .Cells(5, varCol).Resize(Ubound(ArrayAusgabe(A)) + 1, 1) = _
            Application.Transpose(ArrayAusgabe(A))
        End If
    Next A
End With

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

bestimmte Spalten mit Werten füllen

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

bestimmte Spalten mit Werten füllen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread