Mit VBA Werte aus Tabellen auf übersicht kopieren

Guten Morgen zusammen,
habe da mal wieder eine Frage - villeicht hat ja einer von euch eine solche Lösung schon mal bearbeitet und hat noch einen Code rumliegen den ich mir schnell anpassen könnte?
Und zwar möchte ich gerne auf einer Übesichtstabelle (erste Tabelle) in der Arbeitsmappe, automatisch den Wert Datum (z.B. a1) und den Wert Bezeichnung (z.B. B1)von mehreren Tabellenblätern untereinander angeordnet darstellen. Die übrigen Tabellenblätter werden von anderen Benutzern angelegt und beinhalten immer diese beiden Werte die ich gerne Übersichtlich, nach Datum sotiert, auf der ersten Tabelle angezeigt haben möchte - am liebsten mit Link vom jeweiligen Datensatz zur Ursprungstabelle?
Ich hoffe es ist verständlich - habt ihr soetwas schon mal gemacht?
Ich bedanke mich schon mal für alle Hilfestellung
MFG

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub übersicht() Dim wks As Worksheet Dim wrk As Workbook Set wrk = ActiveWorkbook 'Working in active workbook For Each wks In ActiveWorkbook.Worksheets i = i + 1 Next wks 'in i steht jetzt die Anzahl der Tabellen, inklusive der Übersichtstabelle For w = 2 To i target_a = "a" & w - 1 target_b = "b" & w - 1 ActiveWorkbook.Worksheets("Übersicht").Range(target_a) = _ ActiveWorkbook.Worksheets(w).Range("a1").Value ActiveWorkbook.Worksheets("Übersicht").Range(target_b) = _ ActiveWorkbook.Worksheets(w).Range("b1").Value Next w With ActiveWorkbook.Worksheets("Übersicht").Sort .SetRange Range("A:B") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub

For w = 2 To i target_a = "a" & w - 1 target_b = "b" & w - 1 With ActiveWorkbook.Worksheets("Übersicht") .Range(target_a) = ActiveWorkbook.Worksheets(w).Range("a1").Value .Range(target_b) = ActiveWorkbook.Worksheets(w).Range("b1").Value Hyperlinks.Add anchor:=.Range(target_a), Address:="", _ SubAddress:=Worksheets(w).Name & "!A1" End With Next w

Private Sub Workbook_Open() Sheets("Übersicht").Activate Range("A1:d1000").Select Selection.ClearContents Dim wks As Worksheet Dim wrk As Workbook 'Working in active workbook Set wrk = ActiveWorkbook For Each wks In ActiveWorkbook.Worksheets i = i + 1 Next wks 'in i steht jetzt die Anzahl der Tabellen, inklusive der Übersichtstabelle For w = 2 To i target_r = "A" & w - 1 target_b = "B" & w - 1 With ActiveWorkbook.Worksheets("Übersicht") .Range(target_r) = ActiveWorkbook.Worksheets(w).Range("R3").Value .Range(target_b) = ActiveWorkbook.Worksheets(w).Range("B6").Value .Hyperlinks.Add anchor:=.Range(target_r), Address:="", SubAddress:=Worksheets(w).Name & "! _ R3" End With Next w With ActiveWorkbook.Worksheets("Übersicht").Sort .SetRange Range("A:B") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub

Private Sub Workbook_Open() Sheets("Übersicht").Activate Range("A1:d1000").Select Selection.ClearContents Dim wks As Worksheet Dim wrk As Workbook 'Working in active workbook Set wrk = ActiveWorkbook For Each wks In ActiveWorkbook.Worksheets i = i + 1 Next wks 'in i steht jetzt die Anzahl der Tabellen, inklusive der Übersichtstabelle For w = 2 To i target_r = "A" & w - 1 target_b = "B" & w - 1 target_c = "C" & w - 1 With ActiveWorkbook.Worksheets("Übersicht") .Range(target_r) = ActiveWorkbook.Worksheets(w).Range("R3").Value .Range(target_b) = ActiveWorkbook.Worksheets(w).Range("B6").Value .Range(target_c) = ActiveWorkbook.Worksheets(w).Range("Q6").Value .Hyperlinks.Add anchor:=.Range(target_r), Address:="", SubAddress:=Worksheets(w).Name & "! _ R3" End With Next w With ActiveWorkbook.Worksheets("Übersicht") Range("A1:C1").Select Selection.AutoFilter '''*** Sortieren ***''' ActiveSheet.UsedRange.Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:=xlYes, MatchCase:= _ False, DataOption1:=xlSortTextAsNumbers End With Application.ScreenUpdating = 0 For w = 2 To i Sheets(w).[w3] = w Sheets(w).Name = w - 1 Next Application.ScreenUpdating = -1 End End Sub

Hallo,
hier mal eine Variante.
Ich gehe davon aus,
dass dieses gesuchte Datum auf der ersten Tabelle in A1 und die Bezeichnung in B1 befindet.
Die zu durchsuchenden Bereiche sind in den anderen Tabellen in A (Datum) und B (Bezeichnung).

Option Explicit

Sub Find_Data()
Dim tmpArray(), NewArray()
Dim n&, nn&, nnn&
Dim oWS As Worksheet, rngTmp As Range
Dim SuchDatum As Date, SuchBezeichnung

With Worksheets(1)
    SuchDatum = .Cells(1, 1)
    SuchBezeichnung = .Cells(1, 2)
    
    For Each oWS In ThisWorkbook.Worksheets
        If oWS.Index > 1 Then
            With oWS
                Set rngTmp = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2)
                tmpArray = rngTmp
                nn = nnn + Application.WorksheetFunction.CountIf(rngTmp.Columns(2), SuchBezeichnung)
                Redim Preserve NewArray(1 To 2, 1 To nn)
            End With
            For n = 1 To Ubound(tmpArray)
                If Fix(tmpArray(n, 1)) = SuchDatum Then
                    If tmpArray(n, 2) = SuchBezeichnung Then
                        nnn = nnn + 1
                        NewArray(1, nnn) = "=Hyperlink(""#" & rngTmp.Cells(n, 1).Address(0, 0, External:=True) & """,""" & tmpArray(n, 1) & """)"
                        NewArray(2, nnn) = tmpArray(n, 2)
                    End If
                End If
            Next n
            Redim Preserve NewArray(1 To 2, 1 To nnn)
        End If
    Next oWS
    
    .Range("A2:B" & Rows.Count).ClearContents
    If nnn > 0 Then
        TransPoseArray NewArray
        With .Cells(2, 1).Resize(Ubound(NewArray), Ubound(NewArray, 2))
            .Value = NewArray
            .Sort key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
        End With
    End If
End With
End Sub

Sub TransPoseArray(varArray)
Dim n&, nn&, NewAr()
Redim Preserve NewAr(1 To Ubound(varArray, 2), 1 To Ubound(varArray))
For n = 1 To Ubound(varArray)
    For nn = 1 To Ubound(varArray, 2)
        NewAr(nn, n) = varArray(n, nn)
    Next nn
Next n
varArray = NewAr
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Mit VBA Werte aus Tabellen auf übersicht kopieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

357 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mit VBA Werte aus Tabellen auf übersicht kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

357 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread