Werte in 2. Tabelle übertragen

Hallo Gemeinde
Ich hab ein Problem. Und zwar möchte ich ein Archiv erstellen in dem verschiedene Anlagen aufgelistet sind und wann diese benutzt wurden und durch wen.
Um mein Problem anschaulicher zu darzustellen, hab ich mal eine Beispieldatei erstellt auf die ich mich jetzt beziehe.
In das Blatt "Plan" wird eingetragen wer die Anlage wann bedient hat. Die Eingabe
des Datums erfolgt durch Doppelklick, was ich mit einem Makro gelöst hab. Die Eingabe des Bedieners erfolgt über eine Dropdown-Liste.
Diese Daten sollen nun fortlaufend in das Blatt "Liste" übertragen werden. Das heißt wenn bei Anlage 1 ein neues Datum eingetragen wird , soll dies unter dem alten Datum stehen und daneben der jeweilige Benutzer.
Meine Beispieldatei :
https://www.herber.de/bbs/user/116013.xlsm
Ich hoffe ich konnte mein Problem sinnig darstellen und bedanke mich jetzt schon für euer Hilfe
Mfg

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Henry,
probier mal.

' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'setzt per Doppelklick das aktuelle Datum & den Benutzernamen
On Error GoTo Fehler

If Not Intersect(Target, Range("B:B")) Is Nothing Then
  If Target.Offset(0, -1) <> "" Then
    Cancel = True
    Application.EnableEvents = False
    Target = Date
    'target.Offset(, 3) = Environ("Username") '(Bei doppelklick wird benutzername mit eingetragen. entfernt 01.09.17)
    
    
  End If
End If

'*** Fehlerbehandlung
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
  Err.Number & vbLf & Err.Description: Err.Clear

End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
Dim varRet As Variant, lngNext As Long, objList As Object

With Target
  If .Count = 1 Then
    If .Column = 2 Or .Column = 4 Then
      If Cells(.Row, 1) <> "" And IsDate(Cells(.Row, 2)) And Cells(.Row, 4) <> "" Then
        Set objList = Sheets("Liste")
        varRet = Application.Match(Cells(.Row, 1), objList.Rows(1), 0)
        If IsNumeric(varRet) Then
          lngNext = Application.Max(3, objList.Cells(Rows.Count, varRet).End(xlUp).Row + 1)
          objList.Cells(lngNext, varRet) = Cells(.Row, 2)
          objList.Cells(lngNext, varRet + 1) = Cells(.Row, 4)
        End If
      End If
    End If
  End If
End With

Set objList = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte in 2. Tabelle übertragen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread