Werte aus einer Tabelle in andere Tabelle

Matthias · 2018-03-12T16:01:48+00:00

Hallo Zusammen, ich glaube, ich habe ein einfaches Problem zu lösen. Aber leider komm ich nicht auf die Lösung. https://www.herber.de/bbs/user/120366.xlsx Ich habe ein Tabellenblatt A: - in Zelle A1 steht "Code" - Zeile 1, ab Spalte B1: Elemente aus dem Periodensystem - Spalte A, ab Zeile A2: Alle Materialien, für dich ich die einzelnen Werte eintragen muss Jetzt habe ich ein anderes Tabellenblatt B: - in Zelle A1 steht "Code" - Spalte A: Alle Materialen (wie in Tabellenblatt A, nur teilweise auf zwei Teilen verteilt und nicht in gleicher Zeile - die Materialen sind auf Blöcke aufgeteilt, so dass nur die Elemente als Überschrift dastehen, welche auf in dem Material vorkommen (das ist mein Problem, welches ich nicht gelöst bekomme) Ich möchte die Werte aus Tabellenblatt B in Tabellenblatt A in die richtige Zelle bringen. Komme aber mit meinen Formelkenntnissen leider nicht weiter. In der Beispieldatei habe ich die Gelb markierten Materialien aus Tabellenblatt B händisch in Tabellenblatt A eingefügt und immer in die richtige Spalte eingefügt. Wünschenswert wäre noch eine farbliche Markierung, wenn ein Wert nicht gefunden wurde, so dass ich manuell überprüfen kann, ob der Wert vorhanden ist. Wäre toll, wenn mir jemand dabei helfen könnte. Mir raucht irgendwie der Kopf... VG Matze

Hallo Matze,
kannst ja mal probieren:

Sub DatenAufteilen()
'Sheet duplizieren
ThisWorkbook.Worksheets("Tabellenblatt B").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = "TEMP"
Dim rng As Range
Dim searchCode As String
Dim searchCol As Integer
Dim lastRow As Long, i As Long, a As Long
lastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
'Verbundzellen aufheben
ActiveSheet.UsedRange.MergeCells = False
'leere Zeilen loeschen
On Error Resume Next
Range("A1", Range("A" & lastRow).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
'Zeilen mit "Analyte" und "Series" loeschen
For i = lastRow To 1 Step -1
If InStr(Range("A" & i), "Analyte") > 0 Or InStr(Range("A" & i), "Series") > 0 Then
Rows(i).EntireRow.Delete
End If
Next i
'Leere Zeile einsetzen + 'Kopf kopieren
Range("A1").EntireRow.Insert
Worksheets("Tabellenblatt A").Range("B1:AC1").Copy Range("AA1")
'Code-Bloecke bestimmen
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For i = lastRow To 2 Step -1
If InStr(Range("A" & i), "Code") > 0 Then
'Spalten aufteilen
For a = 2 To Range("AA" & i).End(xlToLeft).Column
searchCode = Cells(i, a)
searchCol = WorksheetFunction.Match(searchCode, Rows(1), 0)
If searchCol > 0 Then
Range(Cells(i, a), Cells(lastRow + 1, a)).Copy Cells(i, searchCol)
End If
Next a
lastRow = i - 1
End If
Next i
On Error GoTo 0
'Zeilen mit "Code" loeschen
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = lastRow To 1 Step -1
If InStr(Range("A" & i), "Code") > 0 Then
Rows(i).EntireRow.Delete
End If
Next i
'Spalten loeschen
Columns("B:Z").Delete
'Sortieren
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:AC" & lastRow).Sort _
Key1:=ActiveSheet.Range("A2"), Order1:=xlAscending, Header:=xlNo
'Daten verdichten
For i = lastRow To 2 Step -1
If Range("A" & i) = Range("A" & i - 1) Then
Range("A" & i & ":AC" & i).Copy
Range("A" & i - 1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=True,  _
Transpose:=False
Rows(i).EntireRow.Delete
End If
Next i
'Kopieren nach Tabellenblatt A und leere Zellen = Gelb
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:AC" & lastRow).Copy
With Worksheets("Tabellenblatt A")
.Select
.Range("A2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Columns("A:AC").AutoFit
.Range("A1").Select
For Each rng In .Range("A2:AC" & lastRow)
If IsEmpty(rng) Then rng.Interior.ColorIndex = 6
Next rng
End With
Application.CutCopyMode = False
Application.DisplayAlerts = False
Worksheets("TEMP").Delete
Application.DisplayAlerts = True
Set rng = Nothing
End Sub

https://www.herber.de/bbs/user/120511.xls
Passt es?
Gruß
Klaus
PS. Achte auf die Tabellennamen. Du hast "Tabelleblatt A" statt "Tabellenblatt A" geschrieben
Ist im Code korrigiert

Hi Klaus,
vielen vielen Dank :)
Auch für den Hinweis mit Tabellenblatt A.
Für die ersten paar Blätter hat es schon mal super funktioniert. Jetzt muss ich nur die anderen Daten versuchen soweit aufzubereiten, dass sie dieselbe Struktur haben.
Vielleicht noch eine Frage:
Wenn ich mit F8 die einzelnen Schritte durchlaufe, stoppt das Makro bei dem Block:

'Kopieren nach Tabellenblatt A und leere Zellen = Gelb
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:AC" & lastRow).Copy
With Worksheets("Tabellenblatt A")
.Select
.Range("A2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Columns("A:AC").AutoFit
.Range("A1").Select
For Each rng In .Range("A2:AC" & lastRow)
If IsEmpty(rng) Then rng.Interior.ColorIndex = 6
Next rng
End With

und markiert den fetten Teil mit dem Fehler:
"die pastespecial-methode des range objektes konnte nicht ausgeführt werden"
Also, ich verstehe jetzt das meiste was das Makro macht, aber wieso der Fehler auftaucht, wenn ich die einzelnen Schritte durchlaufe, jedoch nicht auftaucht, wenn ich das Makro so durchlaufen lasse, verstehe ich nicht.
Vielen vielen Dank nochmal Klaus! Das Makro ist super.
Dass hier einem so gut geholfen wird, ist echt toll und nicht selbstverständlich :)
Auch an Werner, der mir neue Formeln gezeigt hat, die ich bestimmt mal woanders einbauen kann :)
Grüße,
Matze

Werte aus einer Tabelle in andere Tabelle

Forumthread: Werte aus einer Tabelle in andere Tabelle

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Werte aus einer Tabelle in andere Tabelle

Forumthread: Werte aus einer Tabelle in andere Tabelle

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread