4 Makros Zusammenfügen ??

[mellow]

Hi,
Kann das dann trotzdem  so funktionieren , das die Zeile auch so festgesetzt wird ?

Danke
Gruss mellow

[ralf_b]

was meinst du mit " Zeile festsetzen" ?

die Frage nach der Msg im 2ten Makro verwirrt mich etwas. Immerhin wird das "x" doch erst gesetzt. Wieso gleich wieder diese Aktion in Frage stellen?

[mellow]

was meinst du mit " Zeile festsetzen" ?

Folgendes hat dieses Makro bis jetzt immer gemacht.

Ich habe mir sämtliche Daten per Sverweis aus einer andere Datei geholt...und Per Import kamen diese Daten vom Server.
Nach Rechnungsfaktura weden die Daten aber verändert oder gelöscht. Somit waren die Bezüge natürlich dann weg.
Das Makro hat dafür gesorgt, das die Einträge so bleiben.

Gruß mellow

[ralf_b]

Code:

Range("$B$" & .Row & ":$I$" & .Row) = Range("$B$" & .Row & ":$I$" & .Row).Value

dafür ist diese Zeile zuständig.  Die aber nur abgearbeitet wird, wenn in spalte A  ein x ist und die aktuelle Aktion in Spalte A stattfindet.
das Copy und Paste habe ich rausgenommen, weil dafür unnötig.

[mellow]

Moin,

also ich hab das mal Probiert....

das zweite makro soll ja in Spalte A ein x automatisch einfügen und dann dadurch das 3. makro ansprechen, damit die Zeile festgesetzt wird.
So der Gedankengang So sind Einträge wieder weg...wenn aus der Usprungsdatei die Daten gelöscht werden.

Funktioniert aber leider so nicht, erst bei manueller Eingabe des x in Spalte A werden die Zeilen festgesetzt. 

Gibt es eine Möglichkeit das dies automatisch passiert ?

Gruß Mellow

[ralf_b]

moin, 
das ist 6 Monate her. Und jetzt hast du es "probiert".  Naja ich weis nicht mehr so recht um was es da ging. Wäre vielleicht gut du postest mal den aktuellen Code und die Fragestellung. Ist nämlich lästig den ganzen Thread noch mal durchzuarbeiten.

[mellow]

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If InStr(Target.Address, ":") Then Exit Sub
'Bereich in Spalte L ist beliebig erweiterbar!
If Not Intersect(Target, Range("L3:L30000")) Is Nothing Then
   If Target.Value = 1 Then _
      Target.Offset(0, 1) = " unterwegs:  " & Now
   If Target.Value = 2 Then _
      Target.Offset(0, 1) = " entladen:     " & Now
   If Target.Value = 0 Then Target.Offset(0, 1) = ""
End If
 
Dim rngTMP As Range
    On Error GoTo Fin
    Application.EnableEvents = False
    ' Nur Spalte E und ab Zeile 8
    If Target.Column = 5 And Target.Row > 7 Then
        ' Wenn mehrere Zellen, dann...
        For Each rngTMP In Target
            If Trim(rngTMP.Value) <> "" Then
                rngTMP.Offset(, 7).Value = 0
                rngTMP.Offset(, -4).Value = "x"
                rngTMP.Offset(, 1).Hyperlinks.Add Anchor:=rngTMP.Offset(, 1), _
                    Address:="https://www.google.de/maps/place/" & _
                    rngTMP.Offset(, 2) & ",+" & rngTMP.Offset(, 10), _
                    TextToDisplay:="Google Maps"
            Else
                rngTMP.Offset(, 7).Value = "0"
                rngTMP.Offset(, 1).Value = ""
            End If
        Next rngTMP
    End If

Fin:
    Application.EnableEvents = True
         
           
    Dim varTargetR, strB
' Makro startet nur, wenn in Spalte A was geändert wird
If Target.Column <> 1 Then Exit Sub
' Zeilennummer festhalten
varTargetR = Target.Row
' Wenn kein x drin ist, nix machen
If Cells(varTargetR, 1) = "x" Then
 
' Meldung Anfang ###-------------------------------------------------------------- ##
  ' Diese Meldung kannst löschen, wenn sie nervt
  If MsgBox("Dispo auflösen?", vbYesNo + vbQuestion, "Dispoplan") = vbNo Then
    Cells(varTargetR, 1) = ""
    Range("$A$" & varTargetR).Select
    Exit Sub
  End If
' Meldung Ende ###-------------------------------------------------------------- ##
 
  ' Bereich markieren und Formeln auflösen
  Range("$B$" & varTargetR & ":$P$" & varTargetR).Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Range("$A$" & varTargetR).Select
  Application.CutCopyMode = False
End If

End Sub

Hallo, hier der gesammte Code ..

ich wollte durch eingabe in Spalte 5  auch automatisch in Spalte A ein x gesetz wird, damit das letzte  Makro angesprochen wird um die Zeilen  festzusetzten, damit diese nicht gelöscht werden, wen die Rohdaten aus der anderen Datei gelöscht werden.

Aber so funktioniert es leider nicht,  das x wird zwar gesetzt aber Zeile wird nicht festgesetz. Ist der Eintrag aus den Rohdaten weg , ist auch der Eintrag in der Tabelle weg.

Setzte ich per Tastatur das x bleibt der Inhalt der Zeile vorhanden.



Danke




Gruß mellow

[ralf_b]

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If InStr(Target.Address, ":") Then Exit Sub
   
    'Bereich in Spalte L ist beliebig erweiterbar!
    Application.EnableEvents = False
    On Error GoTo Fin
   
    Select Case Target.Column
       
        Case 12                                   'L
            If Not Intersect(Target, Range("L3:L30000")) Is Nothing Then
                If Target.Value = 1 Then _
                   Target.Offset(0, 1) = " unterwegs:  " & Now
                If Target.Value = 2 Then _
                   Target.Offset(0, 1) = " entladen:     " & Now
                If Target.Value = 0 Then Target.Offset(0, 1) = ""
            End If
           
        Case 5                                    'E
           
            Application.EnableEvents = False
            ' Nur Spalte E und ab Zeile 8
            If Target.Row > 7 Then
                ' Wenn mehrere Zellen, dann...
               
                If Trim(Target.Value) <> "" Then
                   
                    Target.Offset(, -4).Value = "x" 'A
                   
                    'F
                    Target.Offset(, 1).Hyperlinks.Add Anchor:=Target.Offset(, 1), _
                    Address:="https://www.google.de/maps/place/" & _
                    Target.Offset(, 2) & ",+" & Target.Offset(, 10), _
                    TextToDisplay:="Google Maps"
                   
                    Target.Offset(, 7).Value = 0  'L
                   
                Else
                    Target.Offset(, 1).Value = "" 'F
                    Target.Offset(, 7).Value = "0" 'L
                End If
               
            End If
           
           
        Case 1                                    'A
           
            Dim varTargetR, strB
           
            ' Zeilennummer festhalten
            varTargetR = Target.Row
           
            ' Wenn kein x drin ist, nix machen
            If Cells(varTargetR, 1) <> "x" Then GoTo Fin
           
            'festen Wert einsetzen
            Cells(varTargetR, 1).Value = Cells(varTargetR, 1).Value
           
            ' Meldung Anfang ###-------------------------------------------------------------- ##
            If MsgBox("Dispo auflösen?", vbYesNo + vbQuestion, "Dispoplan") = vbNo Then
                Cells(varTargetR, 1) = ""
                GoTo Fin
            End If
            ' Meldung Ende ###-------------------------------------------------------------- ##
           
            ' Bereich markieren und Formeln auflösen
            With Range("$B$" & varTargetR & ":$P$" & varTargetR)
                .Value = .Value
            End With
           
            Range("$A$" & varTargetR).Select
           
    End Select
   
Fin:
    Application.EnableEvents = True

End Sub

vielleicht gehts ja so.

[schauan]

Hallöchen,

wer alles ein x in a will ...
Hyperlink zu Google Maps

[mellow]

@ schauan....dieser Beitrag ist ja schon was älter und dieser Code ist auch mit dabei