Thema Datum  Von Nutzer Rating
Antwort
22.02.2021 17:17:48 Christian
*****
NotSolved
22.02.2021 19:16:38 AlterDresdner
Solved
22.02.2021 19:56:31 volti
Solved
23.02.2021 16:11:29 Gast40939
NotSolved
24.02.2021 11:43:05 AlterDresdner
Solved
Blau Auswählbare Daten aus einer Datei in andere kopieren
23.02.2021 21:44:05 Trägheit
Solved

Ansicht des Beitrags:
Von:
Trägheit
Datum:
23.02.2021 21:44:05
Views:
246
Rating: Antwort:
 Nein
Thema:
Auswählbare Daten aus einer Datei in andere kopieren

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


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
22.02.2021 17:17:48 Christian
*****
NotSolved
22.02.2021 19:16:38 AlterDresdner
Solved
22.02.2021 19:56:31 volti
Solved
23.02.2021 16:11:29 Gast40939
NotSolved
24.02.2021 11:43:05 AlterDresdner
Solved
Blau Auswählbare Daten aus einer Datei in andere kopieren
23.02.2021 21:44:05 Trägheit
Solved