Datensätze automatisch übertragen in 2. Tabelle

Hallo zusammen,
ich habe folgendes Problem und bisher noch keine Lösung dafür gefunden:
In der ersten Tabelle mit dem Namen "Datenbank" werden laufend neue Datensätze zu Literatur-/Internetquellen gesammelt. Hier sollen alle Informationen, die basiernd auf einer Literaturrecherche gefunden werden, händisch eingetragen werden.
In der zweiten Tabelle mit dem Namen "Übersicht" sollen dann schließlich nur die Datensätze automatisch ausgegeben werden, deren Quellen auf einen "wissenschaftlichen Paper" bezogen ist. Es sollen auch nicht alle Spalten in die zweite Tabelle übernommen werden.
Durch fortlaufendes Erweitern der ersten Tabelle soll die zweite Tabelle natürlich automatisch angepasst werden.
Gibt es hierfür eine Lösung, wie man dies VBA-technisch lösen kann oder ist dies auch mit Funktionen möglich. Leider bin ich in VBA nicht so fit.
Die Excel-Datei habe ich angehängt um ein besser Verständnis meines Problems zu bekommen:

Die Datei https://www.herber.de/bbs/user/106989.xlsm wurde aus Datenschutzgründen gelöscht

Über jegliche Lösungen/Hinweise/Hilfe bin ich sehr dankbar.
Gruß
Domi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Bla() Dim i, x, o As Long Dim wsD, wsU As Worksheet Dim rng, rng2, data, zelle As Range Application.ScreenUpdating = False Set wsD = Worksheets("Datenbank") Set wsU = Worksheets("Übersicht") wsU.Range("Tabelle3").ClearContents wsU.ListObjects("Tabelle3").Resize Range("$B$7:$N$8") Set rng = wsD.Range("B7:B" & wsD.Cells(1048576, 2).End(xlUp).Row) Set rng2 = wsD.Range("B6:X6") x = 2 o = 1 For Each zelle In rng If Not zelle.Value = "" Then h = wsU.Cells(1048576, 2).End(xlUp).Row For i = 2 To 14 Set data = rng2.Find(wsU.Cells(7, x), LookIn:=xlValues) wsU.Cells(h + 1 - o, i) = wsD.Cells(zelle.Row, data.Column) x = x + 1 Next i End If o = 0 x = 2 i = 2 Next zelle Application.ScreenUpdating = True End Sub

Sub Bla() Dim i, x, o As Long Dim wsD, wsU As Worksheet Dim rng, rng2, data, zelle As Range Application.ScreenUpdating = False Set wsD = Worksheets("Datenbank") Set wsU = Worksheets("Übersicht") wsU.Range("Tabelle3").ClearContents wsU.ListObjects("Tabelle3").Resize Range("$B$7:$N$8") Set rng = wsD.Range("B7:B" & wsD.Cells(1048576, 2).End(xlUp).Row) Set rng2 = wsD.Range("B6:X6") x = 2 o = 1 For Each zelle In rng If Not zelle.Value = "" Then h = wsU.Cells(1048576, 2).End(xlUp).Row For i = 2 To 14 Set data = rng2.Find(wsU.Cells(7, i), LookIn:=xlValues) wsU.Cells(h + 1 - o, i) = wsD.Cells(zelle.Row, data.Column) Next i End If o = 0 i = 2 Next zelle Application.ScreenUpdating = True End Sub

Hey Domi
Ich habe den Code etwas geändert nun könntest du bei Übersicht eine Spalten überschrieft von der einen seite nehmen und hinter Kryogene Kühlung packen und er würde Automatisch diese Spalte füllen aber Achtung die Überschrieften von beiden Sheets müssen identisch sein sonst kommt ein Fehler.
Und er sollte nun auch nur die Zeilen kopieren dei mit dem Wissenschaftlicher Paper

Sub Bla()
Dim i, x, o As Long
Dim wsD, wsU As Worksheet
Dim rng, rng2, data, zelle As Range
Application.ScreenUpdating = False
Set wsD = Worksheets("Datenbank")
Set wsU = Worksheets("Übersicht")
wsU.Range("Tabelle3").ClearContents
wsU.ListObjects("Tabelle3").Resize Range(wsU.Cells(7, 2).Address & ":" & wsU.Cells(8, wsU.Cells( _
7, 256).End(xlToLeft).Column).Address)
Set rng = wsD.Range("B7:B" & wsD.Cells(1048576, 2).End(xlUp).Row)
Set rng2 = wsD.Range(wsD.Cells(6, 2), wsD.Cells(6, wsD.Cells(6, 256).End(xlToLeft).Column))
o = 1
For Each zelle In rng
If Not zelle.Value = "" And zelle.Offset(0, 5).Value = "Wissenschaftlicher Paper" Then
h = wsU.Cells(1048576, 2).End(xlUp).Row
For i = 2 To wsU.Cells(7, 256).End(xlToLeft).Column
Set data = rng2.Find(wsU.Cells(7, i), LookIn:=xlValues)
wsU.Cells(h + 1 - o, i) = wsD.Cells(zelle.Row, data.Column)
Next i
End If
o = 0
i = 2
Next zelle
Application.ScreenUpdating = True
End Sub

Sub Bla() Dim i, x, o, h As Long Dim wsD, wsU As Worksheet Dim rng, rng2, data, zelle As Range Application.ScreenUpdating = False Set wsD = Worksheets("Datenbank") Set wsU = Worksheets("Übersicht") wsU.Range("Tabelle3").ClearContents wsU.ListObjects("Tabelle3").Resize Range(wsU.Cells(7, 2).Address & ":" & wsU.Cells(8, wsU.Cells( _ _ 7, 256).End(xlToLeft).Column).Address) Set rng = wsD.Range("B7:B" & wsD.Cells(1048576, 2).End(xlUp).Row) Set rng2 = wsD.Range(wsD.Cells(6, 2), wsD.Cells(6, wsD.Cells(6, 256).End(xlToLeft).Column)) o = 1 For Each zelle In rng If Not zelle.Value = "" And zelle.Offset(0, 5).Value = "Wissenschaftlicher Paper" Then h = wsU.Cells(1048576, 2).End(xlUp).Row For i = 2 To wsU.Cells(7, 256).End(xlToLeft).Column Set data = rng2.Find(wsU.Cells(7, i), LookIn:=xlValues) If Not data Is Nothing Then wsU.Cells(h + 1 - o, i) = wsD.Cells(zelle.Row, data. _ Column) Else 'MsgBox wsU.Cells(7, i).Value & " in " & wsD.Name & " nicht gefunden" Next i End If o = 0 i = 2 Next zelle Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Datensätze automatisch übertragen in 2. Tabelle

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datensätze automatisch übertragen in 2. Tabelle

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread