Thema Datum  Von Nutzer Rating
Antwort
29.03.2011 14:33:51 Mario H
Solved
29.03.2011 14:40:48 Severus
*****
Solved
29.03.2011 14:56:30 Mario H
NotSolved
29.03.2011 16:09:56 Severus
NotSolved
Rot Werte aus nebenstehnder Zelle übernehmen
14.04.2011 12:45:47 Mario H
NotSolved
14.04.2011 13:51:41 Severus
NotSolved
14.04.2011 14:23:00 Mario H
NotSolved
14.04.2011 15:03:07 Severus
NotSolved
15.04.2011 10:44:20 Gast61568
NotSolved
15.04.2011 11:38:36 Severus
NotSolved
15.04.2011 13:13:34 Mario H
NotSolved
15.04.2011 18:36:21 Severus
NotSolved
15.04.2011 17:59:48 Mario H
NotSolved
15.04.2011 18:37:41 Severus
NotSolved
16.04.2011 04:54:29 Severus
*****
Solved
21.04.2011 10:43:54 Mario H
NotSolved
21.04.2011 10:48:45 Mario H
NotSolved
21.04.2011 10:48:46 Mario H
NotSolved
21.04.2011 11:09:06 Serverus
NotSolved
21.04.2011 11:31:09 Mario H
NotSolved
21.04.2011 16:33:17 Severus
NotSolved

Ansicht des Beitrags:
Von:
Mario H
Datum:
14.04.2011 12:45:47
Views:
1366
Rating: Antwort:
  Ja
Thema:
Werte aus nebenstehnder Zelle übernehmen

Hallo noch einmal, der Code für die Tabellen sieht nun wie folgt aus:

Private Sub Worksheet_activate()
' Im Tabellenblatt wurde eine Berechnung durchgeführt
Dim i As Double, zeile As Double
zeile = 0
' Übereinstimmung wird geprüft (hat sich was in den M-Zellen geändert?)
For i = 0 To UBound(arrG)
    zeile = i + 1
    ' Wenn gespeicherter Wert ungleich aktueller Wert in M, dann ...
    If arrG(i) <> Cells(zeile, 13) Then
        ' ...: wenn Zelle J = alter Wert M, dann
        If Cells(zeile, 10) = arrG(i) Then
            ' Wertzuweisung J-Zelle und neuer Wert, ...
            arrG(i) = Cells(zeile, 13)
            Cells(zeile, 10) = Cells(zeile, 13)
        Else
            ' ...sonst nur M-Zelle in Array
            arrG(i) = Cells(zeile, 13)
        End If
    End If
Next
End Sub
  



Private Sub Worksheet_Calculate()
' Im Tabellenblatt wurde eine Berechnung durchgeführt
Dim i As Double, zeile As Double
zeile = 0
' Übereinstimmung wird geprüft (hat sich was in den M-Zellen geändert?)
For i = 0 To UBound(arrG)
    zeile = i + 1
    ' Wenn gespeicherter Wert ungleich aktueller Wert in M, dann ...
    If arrG(i) <> Cells(zeile, 13) Then
        ' ...: wenn Zelle J = alter Wert M, dann
        If Cells(zeile, 10) = arrG(i) Then
            ' Wertzuweisung J-Zelle und neuer Wert, ...
            arrG(i) = Cells(zeile, 13)
            Cells(zeile, 10) = Cells(zeile, 13)
        Else
            ' ...sonst nur M-Zelle in Array
            arrG(i) = Cells(zeile, 13)
        End If
    End If
Next
End Sub
  
Private Sub Worksheet_Change(ByVal Target As Range)
' Weiterhin für manuelle Änderung in J-Zellen
    Dim rC As Range
    Application.EnableEvents = False
    If Not Intersect(Target, Range("M1:M1000")) Is Nothing Then
        For Each rC In Target
            If rC.Column = 13 Then
                If rC.Offset(0, -3) = "" Then rC.Offset(0, -3) = rC
            End If
        Next rC
    End If
    If Not Intersect(Target, Range("J1:J1000")) Is Nothing Then
        For Each rC In Target
            If rC.Column = 10 Then
                If rC = "" Then rC = rC.Offset(0, 3)
            End If
        Next rC
    End If
    Application.EnableEvents = True
End Sub



Leider tritt folgendes Problem auf:

Ich wende den Code auf mehrere Tabelleblättern an.

Wenn ich nun einen automatisch eingetragenen Wert aus Spalte J:J von einem Tabellen Blatt in ein anderes übertragen möchte (einfach Verknüpfung) funktioniert der Code in dem Tabellenblatt nicht mehr aus dem ich den Wert übertrage. Zur Veranschaulichung habe ich eine einfache Datei erstellt, weiß allerdings nicht wie ich sie hier anhängen kann. Ggf. könnte ich Sie per Mail zusenden.


Kann mir jemand bei dem Problem helfen? 
Ich würde mich sehr freuen. 
Besten Gruß 
Mario


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
29.03.2011 14:33:51 Mario H
Solved
29.03.2011 14:40:48 Severus
*****
Solved
29.03.2011 14:56:30 Mario H
NotSolved
29.03.2011 16:09:56 Severus
NotSolved
Rot Werte aus nebenstehnder Zelle übernehmen
14.04.2011 12:45:47 Mario H
NotSolved
14.04.2011 13:51:41 Severus
NotSolved
14.04.2011 14:23:00 Mario H
NotSolved
14.04.2011 15:03:07 Severus
NotSolved
15.04.2011 10:44:20 Gast61568
NotSolved
15.04.2011 11:38:36 Severus
NotSolved
15.04.2011 13:13:34 Mario H
NotSolved
15.04.2011 18:36:21 Severus
NotSolved
15.04.2011 17:59:48 Mario H
NotSolved
15.04.2011 18:37:41 Severus
NotSolved
16.04.2011 04:54:29 Severus
*****
Solved
21.04.2011 10:43:54 Mario H
NotSolved
21.04.2011 10:48:45 Mario H
NotSolved
21.04.2011 10:48:46 Mario H
NotSolved
21.04.2011 11:09:06 Serverus
NotSolved
21.04.2011 11:31:09 Mario H
NotSolved
21.04.2011 16:33:17 Severus
NotSolved