AW: Bereich zusammenführen-Kor.Testdatei
20.11.2012 12:55:47
Klaus
Hi Gisela,
mach mit ALT+F11 den VBA-Editor auf, doppelclicke im Explorer (der ist links) auf Tabelle1 und kopiere diesen Code in das weiße Fenster.
Um das Makro auszuführen, clicke mit der Maus innerhalb des Codes (also unter Sub Zusammenfuehren() und über End Sub) und drücke F5.
Ich habe den Code kommentiert, so dass du ihn selbst an deine größere Originaltabelle anpassen kannst.
Option Explicit
Sub Zusammenfuehren()
Dim rInput As Range
Dim lOutputRow As Long
Dim iOutputCol As Integer
Dim wksInput As Worksheet
Dim wksOutput As Worksheet
Dim iColInput As Integer
Dim lRowInput As Long
'im Original heisst die Tabelle bestimmt nicht "Tabelle1"? Hier anpassen!
Set wksInput = Sheets("Tabelle1")
'ich bin mir fast sicher, im Original werden die Daten in eine andere Tabelle geschrieben?
'falls ich richtig liege, Tabellenname hier anpassen! Wenns im gleichen Blatt liegt, hier und _
bei wksInput halt das gleiche Blatt angeben
Set wksOutput = Sheets("Tabelle1")
'Der absoulte Bereich des Inputs wird hier angebeben, im Beispiel B2:K42 ohne Überschriften / _
Seitenschriften!
'Auf deine Version anpassen!
Set rInput = wksInput.Range("B2:K42")
'in dieser Spalte stehen deine Suchbegriffe (A,AB,AH usw.... Spalte A = 1, B = 2 usw)
iColInput = 1
'in dieser Zeile stehen deine Datums
lRowInput = 1
'Hier den Zellenbezug angeben, AB dem der Output stattfindet. Mit Überschriften!
'Im Beispiel ist die Zelle dazu M1, als Zeile (lOutputRow) = 1 und Spalte (lOutputCol) = 13
'Die Systematik ist einfach Spalte A = 1, B = 2 und so weiter.
'Hier anpassen!
lOutputRow = 1
iOutputCol = 13
'* Ab hier geht das Makro los, da musst du nichts mehr anpassen!
'* eleganter wäre es, alle Zeilen die mit DIM anfangen an den Makroanfang zu stellen.
'* habe ich mit Absicht nicht gemacht, damit es für dich übersichtlicher bleibt.
'* Den Code hier kommentiere ich trotzdem noch durch
Dim rMyCheck As Range
Dim lRowOut As Long
Dim iColOut As Integer
Dim sMatchRow As String
Dim rMatchRow As Range
Dim sMatchCol As String
Dim rMatchCol As Range
For Each rMyCheck In rInput 'prüfe alles im rInput-Bereich (B2:K42 momentan)
If rMyCheck.Value = "" Then 'überspringe leere Zellen
Else 'wenn Zelle NICHT leer, dann:
'finde die ZEILE, in der im Output geschrieben werden muss.
'Dafür nutze ich die Funktion =VERLGEICH (hier: application.match), die mir die Zeile _
zurück gibt (vergleicht Seiten-Überschrift im Input und im Output)
sMatchRow = wksInput.Cells(rMyCheck.Row, iColInput).Value
Set rMatchRow = wksOutput.Range(wksOutput.Cells(lOutputRow, iOutputCol), wksOutput. _
Cells(wksOutput.Rows.Count, iOutputCol))
lRowOut = Application.Match(sMatchRow, rMatchRow.Value, False)
'finde die SPALTE, in der im Output geschrieben werden muss.
'Dafür nutze ich die Funktion =VERLGEICH (hier: application.match), die mir die Zeile _
zurück gibt (vergleicht Überschriften im Input und im Output)
sMatchCol = wksInput.Cells(lRowInput, rMyCheck.Column)
Set rMatchCol = wksOutput.Range(wksOutput.Cells(lOutputRow, iOutputCol), wksOutput. _
Cells(lOutputRow, wksOutput.Columns.Count))
iColOut = Application.Match(sMatchCol, rMatchCol.Value, False)
'SCHREIBE in das Output Blatt, und zwar:
'Zeile: die per Vergleich gefundene Zeile (lRowOut) PLUS die Startzeile (lOutputRow) _
MINUS eins für die Überschrift
'Spalte: die per Vergleich gefundene Spalte (iCOlOut) PLUS die Startspalte (iOutputCol) _
MINUS eins für die Seiten-Überschrift
wksOutput.Cells(lRowOut + lOutputRow - 1, iColOut + iOutputCol - 1).Value = rMyCheck. _
Value
End If
Next rMyCheck
End Sub
Grüße,
Klaus M.vdT.