vba Verknüpfung beidseitig bearbeiten

Question

Hallo Zusammen, könnte mir jemand ein Makro schreiben ich möchte zum Bsp.

Tabelle "test1" die Zeilen K8:K100 mit Tabelle "test2" Zeile G8:G100 verknüpfen so dass ich sie beidseitig bearbeiten kann? 
Damit ich in Tabelle "test1" Zeile K8:K100 und Tabelle "test2" Zeile G8:G100 eine Zahl eingeben kann und es mir immer die nicht bearbeitete Zelle aktualisiert? 

Habe ein ähnliches Beispiel gefunden.

Private Sub Worksheet_Change(ByVal Target As Range) 
Application.EnableEvents = False 
On Error GoTo ERRORHANDLER 
If Target.Cells.Address = "$A$1" Then 
Range("A5") = Range("A1") 
ElseIf Target.Cells.Address = "$A$5" Then 
Range("A1") = Range("A5") 
End If 
ERRORHANDLER: 
Application.EnableEvents = True 
End Sub

Besten Dank.

Answer 1

Hi,

dieselbe Nummerierung muss aber auch in test2 vorhanden sein - dann würde es funktionieren, weil die Datensätze in diesem Fall eindeutig einander zuordenbar sind.

Bis später, Karin

Answer 2

Hallo Karin ja das währe möglich, könnte man auch in Tabelle "test1" in Spalte B8:B100 ein automatische Nummerierung 1,2,3 usw mit einem makro einfügen sobald in Spalte A8:A100 ein Datum eingetragen wird.

Der makro 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target.Cells(1), Range("K8:K100")) Is Nothing Then
        Application.EnableEvents = False
        Worksheets("Test2").Range(Target.Offset(0, -4).Address) = Target.Value
        Application.EnableEvents = True
    End If
End Sub

und in Test2:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target.Cells(1), Range("K8:K100")) Is Nothing Then
        Application.EnableEvents = False
        Worksheets("Test1").Range(Target.Offset(0, 4).Address) = Target.Value
        Application.EnableEvents = True
    End If
End Sub

sollte auch noch funktionsfähig bleiben. Habe in Tabelle "test1" noch ein makro weis aber nicht ob das mit ("a8:o100").Copy funktioniert oder muss ("a8:o100") unterteilt werden.

ThisWorkbook.Worksheets("test1").Activate
'Filter wählen - Namen "L..." Oder "M..." Oder "L*", xlOr, "M*"
ActiveSheet.Range("A7:p100").AutoFilter 10, " ", xlOr, "<9"
'Informationen in ein anderes Tabellenblatt kopieren
ThisWorkbook.Worksheets("test2").Range("a8:K100").ClearContents  'von a8 bis k100 löschen
'Informationen kopieren
ActiveSheet.Range("a8:o100").Copy Destination:=ThisWorkbook.Worksheets("test2").Range("a8") 'mit Formatierung

Vielen Dank.

Answer 3

Hi,

mit deinem Makro kopierst du die gefilterten Daten aus test1 nach test2, d.h. in test2 sind weniger Daten vorhanden als in test1 - oder sehe ich das falsch?

Wenn du die Daten sowieso kopierst brauchst du doch in test1 gar kein Chage_Ereignis um die Änderungen nach test2 zu übertragen - wenn du in test1 Änderungen durchgeführt hast, musst du halt einfach nochmal kopieren. So wie ich das sehe, brauchst du also nur in test2 ein Change_Ereignis, welches die dortigen Änderungen nach test1 überträgt.

Als Außenstehender, der die Mappe, deren Aufbau und das was in der Mappe ausgeführt werden soll nicht kennt, ist es immer sehr schwierig, die konkreten Bedingungen berücksichtigen zu können - deshalb die vielen Rückfragen.

Übrigens: beim Kopieren eines geschlossenen Bereichs muss nichts unterteilt werden.

Bis später, Karin

Answer 4

Hallo Karin das wäre richtig, könntest du mir dieses makro schreiben und die automatische Nummerierung in Tabelle "test1" Spalte B8:B100. Dankeschön

Answer 5

Hi,

für test1 folgender Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Eingabe erfolgt in A8:A100
    If Not Intersect(Target.Cells(1), Range("A8:A100")) Is Nothing Then
        ' Eingabe ist ein Datum
        If IsDate(Target.Cells(1)) Then
            ' Zelle rechts neben Eingabezelle ist leer
            If Target.Cells(1).Offset(0, 1) = "" Then
                ' Zelle rechts neben Eingabezelle = Maximum + 1 aus Bereich B8:B100
                Target.Cells(1).Offset(0, 1) = Application.Max(Range("B8:B100")) + 1
            End If
        End If
    End If
End Sub

für test2 dieser Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim varZeile As Variant
    ' Eingabe erfolgt in K8:K100
    If Not Intersect(Target.Cells(1), Range("K8:K100")) Is Nothing Then
        ' Zeile ermitteln in welcher in B8:B100 test1 der Inhalt aus Eingabezeile Spalte B steht
        varZeile = Application.Match(Target.Cells(1).Offset(0, -9), Worksheets("test1").Range("B8:B100"), 0)
        ' Zeile konnte ermittelt werden dann in K8:K100 test1 Eingabe eintragen
        If IsNumeric(varZeile) Then Worksheets("test1").Range("B8:B100").Cells(varZeile).Offset(0, 9) = Target
    End If
End Sub

Ich habe mal ein paar Kommentare eingefügt damit du besser nachvollziehen kannst was abläuft. Teste einfach mal ob es das ist was du realisieren wolltest.

Bis später, Karin

Answer 6

Vielen Dank Karin, alles macht genau das gewünschte.

Noch eine Frage, wenn ich die Datei öffne kann ich keine Zelle anwählen (corsur nicht sichtbar) wenn ich einen filter anklicke dann kann ich eine Zelle zB. A8 auswählen, was könnte das Problem sein.

Answer 7

Hi,

du musst die Makros und den Inhalt aktivieren. Wenn du die Mappe öffnest solltest du oben den bzw. die entsprechenden Hinweise (erst den einen danach den anderen) angezeigt bekommen.

Du kannst die Mappe auch in einem als sicheren Speicherort festgelegten Ordner ablegen - dann sollten keine Hinweise zu Makros und Inhalt kommen.

Bis später, Karin

Answer 8

Hallo Karin, habe mich wohl falsch ausgedrückt, ich bekomme keine Sicherheitsmeldung sondern die Datei öffnet ganz normal nur der corsur ist nicht sichtbar, ich kann die Zelle A8 auswählen aber der corsur macht keinen Rahmen um die Zelle.

Answer 9

Hallo Karin Danke für deine großzügige Hilfe, das Problem hat sich erledigt, ich habe die makro Reihenfolge geändert.

Answer 10

Hallo Karin guten Tag habe doch noch ein Problem, diese makros befinden sich in (DieseArbeitsmappe) schreib mir bitte diese makros zu einem denn 2mal Sub Workbook_Open() funktioniert nicht. Vielen Dank.

Sub Workbook_Open()

'für alle Blätter mit Passwortschutz NUR TEXT

    Sheets("Test1").Activate    'immer Test1 zuerst öffnen

'Dim ws As Worksheet

For Each ws In Worksheets

    ws.Protect UserInterfaceOnly:=True, Password:="gs", AllowInsertingHyperlinks:=True, AllowFormattingCells:=True  'Passwort anpassen " "   , AllowInsertingHyperlinks:=True = Hyperlink bearbeitbar machen

    ws.EnableAutoFilter = True 'ermöglicht Autofilter

    ws.EnableOutlining = True 'ermöglicht Gruppierung/Gliederung

Next ws

      Dim Loletzte As Long    ' Sub erste_leere_zelle() 

    Loletzte = Cells(Rows.Count, 1).End(xlUp).Row - 17

    Cells(Loletzte, 1).Select

End Sub

Sub Workbook_Open()

'Public Sub Reset_Autofilter()   'Alle Filter ÖFFNEN

    Dim objWorksheet As Worksheet

    For Each objWorksheet In ThisWorkbook.Worksheets

        With objWorksheet

            If .AutoFilterMode Then

                .Protect Password:="gs", _

                    UserInterfaceOnly:=True, AllowFiltering:=True

                If .FilterMode Then .ShowAllData

            End If

        End With

    Next

'End Sub

    ActiveSheet.Range("A7:P100").Select    'sortieren

    Selection.Sort Key1:=Range("f8"), Key2:=Range("g8"), Key3:=Range("c8"), _

    Order1:=xlAscending, Header:=xlYes, _

    OrderCustom:=1, MatchCase:= _

    False, Orientation:=xlTopToBottom

    Dim Loletzte As Long    ' Sub erste_leere_zelle() 

    Loletzte = Cells(Rows.Count, 1).End(xlUp).Row - 17

    Cells(Loletzte, 1).Select

End Sub