|  
                                             Makro kommt in die Zieltabelle - siehe Bild. 
Randbemerkung: Der Name der Tabelle ist nicht weiter wichtig. 
  
Per Doppelklick auf die Beschriftung - in der Zieltabelle - öffnet sich ein Auswahldialog. In diesem kann man die Stammdatenliste auswählen. 
In der Stammdatenliste dann einfach in der Spalte "Name" in die Zelle doppelklicken und die Werte werden nach Angabe in der Zieldatei übertragen. 
'
' Modul: Klassenmodul der Zieltabelle
'
Option Explicit
'/////////////////////////////////////////////////////////////////////////////////////
'//
'/////////////////////////////////////////////////////////////////////////////////////
Private WithEvents m_wkbSource As Excel.Workbook
'Name der Tabelle in der Stammdatenliste, von dem die Datensätze
'per Klick übertragen werden sollen
Private Const C_SOURCE_SHEET_NAME As String = "Stammdatenliste"
'/////////////////////////////////////////////////////////////////////////////////////
'// m_wkbSource
'/////////////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////
'
Private Sub m_wkbSource_BeforeClose(Cancel As Boolean)
  Set m_wkbSource = Nothing
End Sub
'//////////////////////////////////////////
'
Private Sub m_wkbSource_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  m_wkbSource.Saved = True
End Sub
'//////////////////////////////////////////
'
Private Sub m_wkbSource_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  
  'Handelt es sich um das richtige Tabellenblatt
  'und wurde in die richtige Spalte geklickt?
  ' (wenn nicht, Exit)
  If 0 = StrComp(Sh.Name, C_SOURCE_SHEET_NAME, vbTextCompare) _
  Then
    If Target.Column = 1 Then
      Cancel = True
    Else
      Exit Sub
    End If
  Else
    Exit Sub
  End If
  
  Dim lngDstCOffset As Long
  Dim rngDstRHeader As Excel.Range
  Dim rngSrcCHeader As Excel.Range
  
  'Bereich mit den Beschriftungen/Bezeichner (nach diesen werden die Datensätze übertagen)
  Set rngDstRHeader = GetHeader()
  Set rngSrcCHeader = Sh.Range("A1", Sh.Cells(1, Sh.Columns.Count).End(xlToLeft))
  
  'Offset zwischen Beschriftung/Bezeichner und Datensatz im Ziel
  With rngDstRHeader.Worksheet
    lngDstCOffset = .Cells(rngDstRHeader.Cells(1).Row, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
    lngDstCOffset = lngDstCOffset - rngDstRHeader.Column
  End With
  
  Dim rngSrcField As Excel.Range
  Dim rngDstField As Excel.Range
  
  'Beschriftung/Bezeichner der Zieldatei in der Stammdatei suchen.
  'Wird diese in der Stammdatei gefunden, wird dessen Wert
  'in die Zieldatei übertragen.
  For Each rngDstField In rngDstRHeader.Cells
    
    Set rngSrcField = rngSrcCHeader.Find( _
                            What:=rngDstField.Value, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            Searchorder:=xlByRows, _
                            MatchCase:=False)
    
    If Not rngSrcField Is Nothing Then
      rngDstField.Offset(0, lngDstCOffset).Value = rngSrcField.Worksheet.Cells(Target.Row, rngSrcField.Column).Value
    End If
  Next
  
  Call MsgBox("Datensatz wurden übernommen.", vbInformation)
  
End Sub
'/////////////////////////////////////////////////////////////////////////////////////
'//
'/////////////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////
' Stammdatenliste öffnen
Public Sub OpenMasterData()
  
  If Not m_wkbSource Is Nothing Then
    Call m_wkbSource.Close(SaveChanges:=False)
    Set m_wkbSource = Nothing
  End If
  
  Dim vntFilename As Variant
  
  vntFilename = Split(ThisWorkbook.Path, Delimiter:=Application.PathSeparator, Limit:=2)
  Call ChDrive(vntFilename(0))
  Call ChDir(vntFilename(0) & Application.PathSeparator & vntFilename(1))
  
  vntFilename = Application.GetOpenFilename("Excel Stammdatenliste (*.xls*),*.xls*", Title:="Stammdatenliste auswählen")
  
  If VarType(vntFilename) = vbBoolean Then
  'Benutzer hat auf Abbrechen geklickt
    Exit Sub
  ElseIf 0 = StrComp(vntFilename, ThisWorkbook.FullName, vbTextCompare) Then
  'Ohoh, DAU am Werk - hat diese Mappe ausgewählt. xD
    Call MsgBox("Ich soll mich selbst öffnen?" & vbNewLine & _
                "Nope, du zuerst! :P", _
                vbExclamation)
    Exit Sub
  End If
  
  Set m_wkbSource = Workbooks.Open(vntFilename, ReadOnly:=True)
  
  Call MsgBox("Wählen Sie die zu übertragenen Datensätze per Doppelklick in der Spalte ""Name"" aus." & vbNewLine & _
              "Anschließend können Sie die Mappe wieder schließen.", _
              Title:=ThisWorkbook.Name, _
              Buttons:=vbInformation)
  
End Sub
'//////////////////////////////////////////
'
Private Function GetHeader() As Excel.Range
  Set GetHeader = Range("A1", Cells(Rows.Count, "A").End(xlUp))
End Function
'//////////////////////////////////////////
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  With GetHeader()
    'Doppelklickt man in den den Bereich der Beschriftung
    'öffnet das den Auswahldialog für die Stammdateiliste.
    If .Row <= Target.Row And Target.Row <= .Rows(.Rows.Count).Row _
    And .Column <= Target.Column And Target.Column <= .Rows(.Columns.Count).Column _
    Then
      Cancel = True
      Call OpenMasterData
    End If
  End With
End Sub
  
Grüße 
     |