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
|