per Doppelklick Daten in separate Tabelle

Hallo,
ich verwalte meine Vorfahren in Excel und möchte per Doppelklick auf eine Zeile (einen Vorfahren) die Inhalte mehrerer Zeilen in einem separaten Tabellenblatt beliebig positionieren. Das knifflige dabei ist, dass ich die angeklickte Zeile und die Zeilen, die in der angeklickten Zeile in den Spalten F, G, H und I vermerkt sind, haben möchte.
In meiner Beispieldatei möchte ich also bei Doppelklick auf die Nr "7" die Zeilen mit der Nr 7 und 14 und 15 und 3 und 2 (die im Beispiel rot markierten) im Zugriff haben.
Hinweis : Mit Nr ist nicht die Excel-Zeilennummer gemeint, sondern der Wert in Spalte A. Die Excel-Zeilennummer muss also nicht mit der benötigten Nummer übereinstimmen !
https://www.herber.de/bbs/user/45987.xls
Rudi hat mir gestern bereits mitteilen können, wie ich eine einzelne Zeile in eine separate Tabelle bekomme. Dies habe ich bereits in mein Beispiel-Excel-File eingebaut. Vielleicht kann man da aufbauen.
Würde mich sehr freuen, wenn Ihr mir helfen könntet.
Vielen Dank und Grüsse
Dieter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column 1 Then 'Bei Doppelklick in andere Spalte Dim vntHeader, vntTmp vntHeader = Range("A1:H1") vntTmp = Range(Cells(Target.Row, 1), Cells(Target.Row, 8)) Cancel = True With Sheets("Einzelsatz") .Range("a1:a8") = WorksheetFunction.Transpose(vntHeader) .Range("a1:a8").Font.Bold = True .Range("b1:b8") = WorksheetFunction.Transpose(vntTmp) .Range("b1:b8").HorizontalAlignment = xlLeft .Activate End With Else 'Bei Doppelklick in Spalte A Dim rngA As Range, rngGbisJ Set rngA = Me.Cells(Target.Row, 1) Set rngFbisI= Me.Range(Me.Cells(Target.Row, 6), Me.Cells(Target.Row, 9)) Cancel = True With Sheets("Tabelle4") .Range("a1") = rngA.Value .Range("a1").Font.Bold = True .Range("b1") = rngFbisI(1, 1) .Range("b3") = rngFbisI(1, 2) .Range("b4") = rngFbisI(1, 3) .Range("b4") = rngFbisI(1, 4) .Activate End With End If End Sub oder auch einfacher With Sheets("Tabelle4") .Range("a1") = Me.Cells(Target.row,1).Value .Range("a1").Font.Bold = True .Range("b1") = Me.Cells(Target.row,6).Value .Range("b3") = Me.Cells(Target.row,7).Value .Range("b4") = Me.Cells(Target.row,8).Value .Range("b4") = Me.Cells(Target.row,9).Value .Activate End With

Else 'Bei Doppelklick in Spalte A Dim rngA As Range, rngFbisI As Range 'Bereich in Spalte A Zeile 1 bis Target-Zeile zuweisen Set rngA = Me.Range(Me.Cells(1, 1), Target) 'Bereich in Spalte F, Zeile 1 bis SPalte I, Target-Zeile zuweisen Set rngFbisI = Me.Range(Me.Cells(1, 6), Me.Cells(Target.Row, 9)) Cancel = True With Sheets("Tabelle4") .UsedRange.Clear rngA.Copy Destination:=.Range("a1") rngFbisI.Copy Destination:=.Range("b1") .Range("a1:e1").Font.Bold = True .Activate End With End If

Hallo Dieter,
ich hab den Code jetzt komplett umgestrickt. Die Hilfsberechnungen in den Spalten M bis Q in Tabelle1 sind nicht mehr erforderlich. Diese Werte berechnet das Makro jetzt selbst. Ich hab dafür die Function "Zeile" eingefügt, die mit der Methode "Find" die Zeilennummern zu den jeweiligen Nr. ermittelt.
Für die Ausgabe im "Stammblatt" habe ich eine kleine Subroutine geschrieben. Das ist pflegeleichter, als 6 mal den Übertragungscode in der Hauptroutine zu schreiben.
Gruß
Franz


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Ausgabe der Daten zur aktuellen Person in der angeklickten Zeile im Blatt "Stammblatt
Cancel = True
'aktuelle Person
Call Ausgabe(wksQuelle:=Me, wksZiel:=Worksheets("Stammblatt"), _
SpalteZiel:=2, ZeileQuelle:=Target.Row)
'Partner
Call Ausgabe(wksQuelle:=Me, wksZiel:=Worksheets("Stammblatt"), _
SpalteZiel:=3, ZeileQuelle:=Zeile(Cells(Target.Row, 6).Value))
'Vater
Call Ausgabe(wksQuelle:=Me, wksZiel:=Worksheets("Stammblatt"), _
SpalteZiel:=4, ZeileQuelle:=Zeile(Cells(Target.Row, 7).Value))
'Mutter
Call Ausgabe(wksQuelle:=Me, wksZiel:=Worksheets("Stammblatt"), _
SpalteZiel:=5, ZeileQuelle:=Zeile(Cells(Target.Row, 8).Value))
'Kind
Call Ausgabe(wksQuelle:=Me, wksZiel:=Worksheets("Stammblatt"), _
SpalteZiel:=6, ZeileQuelle:=Zeile(Cells(Target.Row, 9).Value))
'partner von
Call Ausgabe(wksQuelle:=Me, wksZiel:=Worksheets("Stammblatt"), _
SpalteZiel:=7, ZeileQuelle:=Zeile(Cells(Target.Row, 10).Value))
Sheets("Stammblatt").Activate
End Sub
Private Function Zeile(Nr As Variant) As Long
'Ermittelt Zeile zu Nummer der gesuchten Person
Dim Zelle As Range
Set Zelle = Me.Columns(1).Find(What:=Nr, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then Zeile = 0 Else Zeile = Zelle.Row
Set Zelle = Nothing
End Function
Sub Ausgabe(wksQuelle As Worksheet, wksZiel As Worksheet, SpalteZiel%, ByVal ZeileQuelle%)
'Trägt Daten der jeweiligen Person in wksZiel ein
With wksZiel
If ZeileQuelle > 0 Then
.Range(.Cells(2, SpalteZiel), .Cells(9, SpalteZiel)) = _
WorksheetFunction.Transpose(wksQuelle.Range(wksQuelle.Cells(ZeileQuelle, 1), _
wksQuelle.Cells(ZeileQuelle, 8)))
Else
'Inhalte im Bereich löschen, wenn keine Nr. zur Informationen vorhanden
.Range(.Cells(2, SpalteZiel), .Cells(9, SpalteZiel)).ClearContents
End If
End With
Set BlattQuelle = Nothing
Set BlattZiel = Nothing
End Sub

Sub Ausgabe(wksQuelle As Worksheet, wksZiel As Worksheet, SpalteZiel%, ByVal ZeileQuelle%) 'Trägt Daten der jeweiligen Person in wksZiel ein Dim Zelle As Range, iI% 'Startzeile in Zieltabelle Const lngZeile As Long = 2 'StartSpalte in Quelle Const iSpalte As Integer = 1 'Anzahl Spalten aus Quelle, die eingefügt werden sollen Const iSpalten As Integer = 8 With wksZiel If ZeileQuelle > 0 Then 'Werte übertragen .Range(.Cells(lngZeile, SpalteZiel), .Cells(lngZeile + iSpalten - 1, SpalteZiel)) = _ WorksheetFunction.Transpose(wksQuelle.Range(wksQuelle.Cells(ZeileQuelle, iSpalte), _ wksQuelle.Cells(ZeileQuelle, iSpalte + iSpalten - 1))) 'Einzelne Zell-Formate übertragen For iI = 1 To iSpalten With .Cells(lngZeile, SpalteZiel).Offset(iI - 1, 0) 'Zellhintergrundfarbe .Interior.ColorIndex = wksQuelle.Cells(ZeileQuelle, _ iSpalte).Offset(0, iI - 1).Interior.ColorIndex 'Zellschriftfarbe .Font.ColorIndex = wksQuelle.Cells(ZeileQuelle, _ iSpalte).Offset(0, iI - 1).Font.ColorIndex End With Next Else 'Aktionen wenn keine Nr. zur Informationen vorhanden With .Range(.Cells(lngZeile, SpalteZiel), _ .Cells(lngZeile + iSpalten - 1, SpalteZiel)) 'Inhalte im Bereich löschen, .ClearContents 'Zellhintergrundfarbe auf ohne zurücksetzen .Interior.ColorIndex = xlColorIndexNone 'Schriftfarbe in Zelle auf automatisch zurücksetzen .Font.ColorIndex = xlAutomatic End With End If End With Set wksQuelle = Nothing Set wksZiel = Nothing Set Zelle = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

per Doppelklick Daten in separate Tabelle

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread