Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1728to1732
1728to1732
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zeilen Automatisch Kopieren

Forumthread: Zeilen Automatisch Kopieren

Zeilen Automatisch Kopieren
25.12.2019 15:30:00
Hans
Hallo,
Haben für inventur eine eingaben liste erstellt, nach eingaben Artnr. wird nur noch Menge eingeben.
Sverweis als VBA und Sprung nach eingaben haben ich geschaft.
Frage
Jetzte möchte ich noch gerne das jeden Zeile eins zu Eins kopiert werden nach Tabelle Protokoll
mit ergänzung vom Zeilenummer, datum und Uhrzeit
Beim kopieren sollte auch noch am beste gespeichert werden.
Datei anbei:
https://www.herber.de/bbs/user/133965.xlsm
Mit freundlichen Grüßen
Hans
Anzeige

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeilen Automatisch Kopieren
25.12.2019 17:50:05
Nepumuk
Hallo Hans,
teste mal:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'sprung Zelle A nach C seh Case
    If Target.Count = 1 Then
        If Target.Row >= 2 And Target.Row <= 8000 Then
            Select Case Target.Column
                Case 1
                    Target.Offset(0, 2).Select
                Case 3
                    If Target.Row < 8000 Then
                        With Worksheets("Protokol").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                            Call Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Copy( _
                                Destination:=.Offset(0, 3))
                            .Value = Target.Row
                            .Offset(0, 1).Value = Date
                            .Offset(0, 2).Value = Time
                        End With
                        Target.Offset(1, -2).Select
                    End If
            End Select
        End If
    End If
    '---------------------------------------------------------------
    'sverweis aus tab1
    Dim var As Variant
    If Target.Column = 1 Then
        With Application
            var = .VLookup(Target.Value, _
                Worksheets("tab1").Columns("A:B"), 2, 0)
            If Not IsError(var) Then
                Application.EnableEvents = False
                On Error GoTo ERRORHANDLER
                Target.Offset(0, 1) = .VLookup(Target.Value, _
                    Worksheets("tab1").Columns("A:C"), 2, 0)
                'Target.Offset(0, 2) = .VLookup(Target.Value, _
                    'Worksheets("tab1").Columns("A:D"), 3, 0)
                'Target.Offset(0, 3) = .VLookup(Target.Value, _
                    'Worksheets("tab1").Columns("A:D"), 4, 0)
            End If
        End With
    End If
    
    ERRORHANDLER:
    Application.EnableEvents = True
End Sub

'Automatische Scroll ab zeilen 8
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    Dim Zeile As Long
    Zeile = Target.Row - 8
    If Zeile < 1 Then Zeile = 1
    ActiveWindow.ScrollRow = Zeile
End Sub

Gruß
Nepumuk
Anzeige
AW: Zeilen Automatisch Kopieren
25.12.2019 18:00:20
Han
Hallo Nepumuk,
Super geht nach eingaben Anzahl, Perfekt. Aber eine kleine sachen im Tab Protokol nur werte kopieren jetzt kopiert alles mit.
beste Grüße
Hans
AW: Zeilen Automatisch Kopieren
25.12.2019 18:18:17
Nepumuk
Hallo Hans,
so?
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'sprung Zelle A nach C seh Case
    If Target.Count = 1 Then
        If Target.Row >= 2 And Target.Row <= 8000 Then
            Select Case Target.Column
                Case 1
                    Target.Offset(0, 2).Select
                Case 3
                    If Target.Row < 8000 Then
                        With Worksheets("Protokol").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                            .Offset(0, 3).Resize(1, 3).Value = _
                                Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Value
                            .Value = Target.Row
                            .Offset(0, 1).Value = Date
                            .Offset(0, 2).Value = Time
                        End With
                        Target.Offset(1, -2).Select
                    End If
            End Select
        End If
    End If
    '---------------------------------------------------------------
    'sverweis aus tab1
    Dim var As Variant
    If Target.Column = 1 Then
        With Application
            var = .VLookup(Target.Value, _
                Worksheets("tab1").Columns("A:B"), 2, 0)
            If Not IsError(var) Then
                Application.EnableEvents = False
                On Error GoTo ERRORHANDLER
                Target.Offset(0, 1) = .VLookup(Target.Value, _
                    Worksheets("tab1").Columns("A:C"), 2, 0)
                'Target.Offset(0, 2) = .VLookup(Target.Value, _
                    'Worksheets("tab1").Columns("A:D"), 3, 0)
                'Target.Offset(0, 3) = .VLookup(Target.Value, _
                    'Worksheets("tab1").Columns("A:D"), 4, 0)
            End If
        End With
    End If
    
    ERRORHANDLER:
    Application.EnableEvents = True
End Sub

Gruß
Nepumuk
Anzeige
AW: Zeilen Automatisch Kopieren
25.12.2019 18:26:43
Hans
Vielen Dank
und noch eine Schöne Abend
Beste Gruße
Hans

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige