Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Mit VBA Werte aus Tabellen auf übersicht kopieren

Mit VBA Werte aus Tabellen auf übersicht kopieren
26.03.2013 09:03:33
BlueJay
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

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

Betreff
Datum
Anwender
Anzeige
AW: Mit VBA Werte aus Tabellen auf übersicht kopieren
26.03.2013 13:11:03
Rainer
Hi BlueJay,
vielleicht in der Art:

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
Mit dem Link habe ich gerade keine Ahnung. Müsste aber irgendwie mit hyperlink.add gehen
Gruß,
Rainer

Anzeige
AW: Mit VBA Werte aus Tabellen auf übersicht kopieren
26.03.2013 13:30:38
Rainer
Hallo nochmal,
ich glaub so müsste es mit Link zum jeweiligen Tabellenblatt gehen (nur die for-schleife geändert und bei der gelegenheit nen with-block mit eingebaut)

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
viele Grüße,
Rainer

Anzeige
AW: Mit VBA Werte aus Tabellen auf übersicht kopieren
26.03.2013 15:02:26
BlueJay
Super - das sieht ja richtig gut aus und macht genau das was ich mir gewünscht habe - ich habe den Code folgendermaßen angepasst:
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
Nun bekomme ich beim Sotierschritt die Fehlermeldung 438 Laufzeitfehler?
Vielen Dank noch mal
MFG

Anzeige
AW: Mit VBA Werte aus Tabellen auf übersicht kopieren
26.03.2013 21:22:01
Rainer
hi,
ich vermute das liegt an Deiner Selection die du oben eingebaut hast.
Verusuche stattt deinen drei zeilen folgende Zeile oben einzubauen:
ActiveWorkbook.Worksheets("Übersicht").Range("A:B").Clear
Ich kann den Fehler nicht nachstellen. Bei mir kommt kein Laufzeitfehler. Mit Deinem Code wird es bei mir allerdings auch nicht sortiert (aber eben ohne Fehlermeldung)
Meines Wissens sollte man es vermeiden, Zellen zu selektieren, solang man es nicht braucht. Der Marko-Rekorder macht das in der Regel, der kann es nicht anders.
Viele Grüße,
Rainer

Anzeige
AW: Mit VBA Werte aus Tabellen auf übersicht kopieren
27.03.2013 08:44:29
BlueJay
Vielen Dank noch mal für alle Hilfe - so habe ich das nun gelöst:
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
Macht was es soll

Anzeige
AW: Mit VBA Werte aus Tabellen auf übersicht kopieren
26.03.2013 13:30:35
Tino
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
Anzeige

368 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige