VBA Schlagwort finden und Wert kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub t() Dim ws1 As Worksheet, ws2 As Worksheet Dim lC As ListColumn, lR As ListRow Set ws1 = ThisWorkbook.Worksheets("Tabelle1") Set ws2 = ThisWorkbook.Worksheets("Tabelle2") With ws1.ListObjects("Tabelle1") Set lR = .ListRows.Add For Each lC In .ListColumns If WorksheetFunction.CountIf(ws2.Range("B:C"), lC.Name) Then _ lR.Range(lC.Index) = WorksheetFunction.VLookup(lC.Name, ws2.Range("B:C"), 2, 0) Next lC End With End Sub

Hi Chris,
WOW - danke! Das sieht so einfach aus.. wäre ich nie im Leben drauf gekommen.
Jetzt habe ich versucht, es ein wenig umzubauen, da meine eigentliche Zieldatei noch etwas komplizierter aussieht (hätte ich vielleicht direkt einfach hochladen sollen...), aber nun scheitere ich doch noch. Kannst du das folgende Problem auch lösen?
Vorne in Tabelle1 habe ich nun für jedes Produkt zwei Spalten (einheitlich immer mit "Produkt H" und "Produkt A" gekennzeichnet.
Die Daten stehen wieder hinten in Tabelle2, jetzt allerdings immer mit zwei Datenwerten pro Artikel. Der eine Datenwert steht immer eine Zelle über dem Produkt (Wert für Produkt H), der andere Wert immer genau eine Zelle darunter (Wert für Produkt A). Zum Verständnis habe ich das mal gelb markiert (das musst man sich dann aber wegdenken, wird in der Zieldatei nicht als "Erklärung" danebenstehen.
Ich dachte, dass ich irgendwie mit offset arbeiten kann, aber dann ist es auch wieder gescheitert...
Jetzt die stehen die Produkte ja auch nicht mehr "untereinander", sodass man die iterativ einfach durchgehen kann. Dafür könnte aber auch eine Hilfstabelle gebaut werden, die einfach alle Produktnamen untereinander stehen hat, damit das Makro weiß, welche Begriffe es nacheinander durchsuchen muss.
https://www.herber.de/bbs/user/156672.xlsx

Sub t() Dim ws1 As Worksheet, ws2 As Worksheet Dim lC As ListColumn, lR As ListRow Dim strSuchtext As String, strKuerzel As String, lngZeile As Long Set ws1 = ThisWorkbook.Worksheets("Tabelle1") Set ws2 = ThisWorkbook.Worksheets("Tabelle2") With ws1.ListObjects("Tabelle1") Set lR = .ListRows.Add For Each lC In .ListColumns strSuchtext = Left(lC.Name, Len(lC.Name) - 2) strKuerzel = Right(lC.Name, 1) If WorksheetFunction.CountIf(ws2.Range("B:B"), strSuchtext) Then lngZeile = Application.Match(strSuchtext, ws2.Range("B:B"), 0) If strKuerzel = "H" Then lR.Range(lC.Index) = ws2.Cells(lngZeile - 1, 2) ElseIf strKuerzel = "A" Then lR.Range(lC.Index) = ws2.Cells(lngZeile + 1, 2) Else MsgBox "Inkonsistenz Kürzel: " & lC.Name End If Else MsgBox "Inkonsistenz Suchtext: " & lC.Name End If Next lC End With End Sub

Sub t() Dim LO As ListObject Dim NeueZeile As ListRow Dim S As Long Dim Z As Range Set LO = ThisWorkbook.Worksheets("Tabelle1").ListObjects(1) With ThisWorkbook.Worksheets("Tabelle2") Set NeueZeile = LO.ListRows.Add For Each Z In .Range("B:B").SpecialCells(xlCellTypeConstants, 2) 'es werden die Texte isoliert S = LOSpalte_exists(LO, Z.Value & " H") 'davon immer nur die Spalte "xxx H" gesucht If S Then 'wenn gefunden NeueZeile.Range(S) = Z.Offset(-1, 0) NeueZeile.Range(S + 1) = Z.Offset(1, 0) Else MsgBox "Spalten " & Z.value & " nicht gefunden." End If Next End With End Sub Function LOSpalte_exists(ByRef LO As ListObject, ColName As String) As Long 'liefert ListObject-Spaltennummer, wenn existent, bleibt sonst 0 On Error Resume Next LOSpalte_exists = LO.ListColumns(ColName).Index End Function

Sub t() Dim ws1 As Worksheet, ws2 As Worksheet Dim lC As ListColumn, lR As ListRow Dim strSuchtext As String, strKuerzel As String, lngZeile As Long Dim letzteZeile As Long Set ws1 = ThisWorkbook.Worksheets("Tabelle1") Set ws2 = ThisWorkbook.Worksheets("Tabelle2") With ws1.ListObjects("Tabelle1") Set lR = .ListRows.Add For Each lC In .ListColumns strSuchtext = Left(lC.Name, Len(lC.Name) - 2) strKuerzel = Right(lC.Name, 1) letzteZeile = ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row Select Case lC.Index Case 1, 2: lR.Range(lC.Index) = ws2.Cells(lC.Index, 2) Case 3: lR.Range(lC.Index) = ws2.Cells(2, 2) Case 4: lR.Range(lC.Index) = ws2.Cells(3, 2) Case 5: lR.Range(lC.Index) = ws2.Cells(7, 2) Case .ListColumns.Count - 2: lR.Range(lC.Index) = ws2.Cells(letzteZeile - 2, 2) Case .ListColumns.Count - 1: lR.Range(lC.Index) = ws2.Cells(letzteZeile - 1, 2) Case .ListColumns.Count: lR.Range(lC.Index) = ws2.Cells(letzteZeile, 2) Case Else If WorksheetFunction.CountIf(ws2.Range("B:B"), strSuchtext) Then lngZeile = Application.Match(strSuchtext, ws2.Range("B:B"), 0) If strKuerzel = "H" Then lR.Range(lC.Index) = ws2.Cells(lngZeile - 1, 2) ElseIf strKuerzel = "A" Then lR.Range(lC.Index) = ws2.Cells(lngZeile + 1, 2) Else MsgBox "Inkonsistenz Kürzel: " & lC.Name End If Else MsgBox "Inkonsistenz Suchtext: " & lC.Name End If End Select Next lC End With End Sub

Hallo JayJay,
ich hätte zuerst gesagt, dass der Code von Chris ohne Anpassung weiter verwendet werden kann, aber ich bin mir nicht sicher, da er auf einige Spalten von Ziel-ListObject per Index und nicht per Überschrift zugreift.
Ich schlage eine alternative Methode vor:
Gemäß deine Vorgabe wird die Spalte B gelesen und "Überschriften" in der Spalte A geschrieben.
Anschliessend wird die Spalte A gelesen, die Ziel-Spalte im ListObject ermittelt und die Werte in Spalte B zugeordnet. Dafür muss aber Datum und Uhrzeit voneinander isoliert werden.
Diese Vorgehensweise sollte einigermassen flexible für zukünftige Änderungen (immer der Krux mit VBA: ändert sich was, ist wieder Chaos)


Sub t()
Dim LO As ListObject
Dim Z As Range
Dim NeueZeile As ListRow
Dim S As Long
Set LO = ThisWorkbook.Worksheets("Tabelle1").ListObjects(1)
With ThisWorkbook.Worksheets("Tabelle2")
'feste Zeilen oben
.Range("A1") = "Titel"
.Range("A2") = "Datum"
.Range("A3") = "Haus"
.Range("A4") = "Uhrzeit"
.Range("A7") = "Hof"
'feste Zeilen unten
With .Range("B99999").End(xlUp)
.Offset(-1, -1) = "Letzte Zahl"
.Offset(-2, -1) = "Vorletzte Zahl"
.Offset(-3, -1) = "Drittletzte Zahl"
End With
'feste Zeilen dazwischen. Muster: Text mit drüber und drunter je einrn Zahl
For Each Z In Range(.Range("B8"), Range("B99999").End(xlUp).Offset(-4)).SpecialCells(xlCellTypeConstants, 2) 'es werden die Texte isoliert
If IsNumeric(Z.Offset(-1, 0)) And IsNumeric(Z.Offset(1, 0)) Then
Z.Offset(-1, -1) = Z.Value & " H"
Z.Offset(1, -1) = Z.Value & " A"
End If
Next
'Achtung: hier ändern wir die Quelldaten
.Range("C2") = .Range("B2").Value 'ortiginale Wert wird zur Seite kopiert zur Kontroll
.Range("B4") = Format(CDate(.Range("B2").Value), "hh:mm")
.Range("B2") = Format(CDate(.Range("B2").Value), "DD.MM.YYYY")
'Jetzt wird gelesen und zugeordnet
Set NeueZeile = LO.ListRows.Add
For Each Z In .Range("A:A").SpecialCells(xlCellTypeConstants, 2) 'es werden die Texte isoliert
If Z.Value  "" Then 'nur wenn nicht leer (was eig. mit Specialcells überflüssig ist)
S = LOSpalte_exists(LO, Z.Value)
If S Then 'wenn gefunden
NeueZeile.Range(S) = Z.Offset(0, 1)
Else
Z.Offset(0, 3) = "Spalte nicht gefunden." 'fehlende werden in Spalte D geschrieben, anstatt Unterbrechung
End If
End If
Next
If .Range("D99999").End(xlUp).Row  1 Then MsgBox "Fehler gefunden: Spalte D in Quellblatt prüfen!"
End With
End Sub
Function LOSpalte_exists(ByRef LO As ListObject, ColName As String) As Long
'liefert ListObject-Spaltennummer, wenn existent, bleibt sonst 0
On Error Resume Next
LOSpalte_exists = LO.ListColumns(ColName).Index
End Function

VG
Yal

Beliebteste Forumthreads (12 Monate)

VBA Schlagwort finden und Wert kopieren

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Schlagwort finden und Wert kopieren

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

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread