Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 21:51:33
Idee für Grafik
26.04.2024 21:29:07
PQ zufällige Reihenfolge
26.04.2024 17:18:47
Große Datenmenge in komplexes Diagramm verpacken
26.04.2024 16:22:47
Aktualisierung Verknüpfung bei geschlossener Quelldatei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1100to1104
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1100to1104
1100to1104
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Kopiermakro um Kontrollabfrage ergänzen

Kopiermakro um Kontrollabfrage ergänzen
Sirenia
Hallo zusammen,
ich habe ein Makro, das mir Spalten kopiert - bin auch sehr sehr glücklich damit. Ich möchte dieses Makro gerne um eine Kontrolle ergänzen:
Das Makro kopiert mir die Zeile 7 komplett in die erste, unbeschriebene Zeile und sortiert die kopierten Zeilen nach Datum. Das Datum steht jeweils in der Spalte A. Ich möchte nun gerne, dass das Makro so ergänzt wird, dass vorher abgefragt wird, ob das Datum schon in meinen kopierten Einträgen vorhanden ist. Dann soll abgefragt werden "Das Datum xx.xx.xxxx ist schon vorhanden. Wirklich überschreiben?" Ja oder Nein.
Bei "Ja" soll dann brav die neue Spalte kopiert werden, bei "Nein" soll das Makro abgebrochen werden.
Hat jemand eine Idee, wie das umgesetzt werden könnte?
Hier schonmal mein bisheriges Kopiermakro: 
Private Sub sortieren_Click()
Dim lngRow As Long
With Sheets("M")
If Application.CountIf(.Columns(1), .Cells(7, 1)) = 1 Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Rows(7).Copy
.Cells(lngRow, 1).PasteSpecial xlPasteValues
.Range(.Cells(10, 1), .Cells(lngRow, 136)).Sort key1:=.Cells(10, 1), order1:= _
xlAscending, header:=xlNo
End If
End With
Next
End Sub

Ich hoffe, ich konnte irgendwie erklären, was ich meine.
Wünsche allen einen guten Start in den Tag!
Viele Grüße,
Sirenia
AW: Kopiermakro um Kontrollabfrage ergänzen
15.09.2009 08:24:40
Tino
Hallo,
wenn ich Dich richtig verstanden habe, müsste es so gehen.
Private Sub sortieren_Click()
  Dim lngRow As Long
    
    With Sheets("M")
      
        lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        
        If IsNumeric(Application.Match(CLng(.Cells(7, 1)), .Range(.Cells(10, 1), .Cells(lngRow, 1)), 0)) Then
         If MsgBox("Datum '" & .Cells(7, 1) & "' schon vorhanden. Wirklich überschreiben?", vbYesNo) = vbNo Then
          Exit Sub
         End If
        End If
        
        .Rows(7).Copy
        .Cells(lngRow, 1).PasteSpecial xlPasteValues
        .Range(.Cells(10, 1), .Cells(lngRow, 136)).Sort key1:=.Cells(10, 1), order1:=xlAscending, Header:=xlNo

    End With
  
End Sub
Gruß Tino
Anzeige
das ist aber kein Überschreiben ;o)
15.09.2009 08:50:56
Matthias
Hallo Tino
Ich war auf dem selben Weg wie Du unterwegs.
In Deinem Beispiel wird allerdings nix überschrieben, sondern ebenfalls fein in die erste leere Zeile geschrieben
Es müsste also heißen "Dieses Datum ist schon eingepflegt, wollen Sie die Daten erneut eintragen"
und nicht "...schon vorhanden. Wirklich überschreiben?"
Gruß Matthias
Und wie geht das nun mit Überschreiben?
15.09.2009 09:00:51
Sirenia
Guten Morgen Matthias,
Guten Morgen Tino,
wie Matthias schon sagte, schreibt dein Makro auch wieder in die erste leere Zeile - ich möchte aber wirklich die Daten überschreiben. Hast du da noch eine Idee, Tino, wie man das Makro abändern muss, dass es wirklich überschreibt? Oder kannst du da weiterhelfen, Matthias?
Ich danke euch schonmal vielmals für eure Ansätze!
Viele Grüße,
Sirenia
Anzeige
probier mal so ...
15.09.2009 09:11:47
Matthias
Hallo
Ich habe es so umgesetzt
Private Sub CommandButton1_Click()
Dim lngRow As Long, rng As Range
With Sheets("M")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
For Each rng In .Range(.Cells(8, 1), .Cells(lngRow, 1))
If rng.Value = .Cells(7, 1).Value Then
If MsgBox("überschreiben?", vbYesNo) = vbYes Then
.Rows(7).Copy
.Cells(rng.Row, 1).PasteSpecial xlPasteValues
.Range(.Cells(10, 1), .Cells(lngRow, 136)).Sort key1:=.Cells(10, 1), order1:= _
xlAscending, Header:=xlNo
Exit Sub
End If
Exit For
End If
Next
If Application.CountIf(.Columns(1), .Cells(7, 1)) = 1 Then
.Rows(7).Copy
.Cells(lngRow, 1).PasteSpecial xlPasteValues
.Range(.Cells(10, 1), .Cells(lngRow, 136)).Sort key1:=.Cells(10, 1), order1:= _
xlAscending, Header:=xlNo
End If
End With
End Sub
Gruß Matthias
Anzeige
AW: probier mal so ...
15.09.2009 09:23:32
Sirenia
Funktioniert ebenfalls einwandfrei :)
Kannst du mir denn sagen, wo der Unterschied zwischen den beiden Makros ist? Funktionieren tun sie ja schließlich beide ;)
Vielen Dank und ganz liebe Grüße!
Sirenia
jeder schreibt eben ein bisschen anders ...
15.09.2009 09:30:27
Matthias
Hallo
Das ist wie mit dem Weg nach Rom "Viele Wege führen dahin" ;o)
Ist einfach nur eine Gewohnheitssache, wie wer programmiert.
allerdings ist mir bei Tino aufgefallen, das wenn Du z.B. nur Daten in Zeile7 stehen hast
sein Makro trotzdem in eine neue Zeile schreibt
Userbild
Das geht bis Zeile10
Dann klappt es dort auch
Gruß Matthias
Anzeige
AW: jeder schreibt eben ein bisschen anders ...
15.09.2009 09:46:25
Sirenia
Der Fehler ist mir vielleicht gar nciht aufgefallen, weil ich schon Datenreihen bis 54 gefüllt habe ;)
Ansonsten finde ich beide Makros klasse. Wenn ich mehr Zeit dazu hätte, würd ich auch gerne VBA-Programmierung lernen. Aber die Zeit wird kommen!
Wünsche euch jedenfalls einen wunderschönen Tag!
Viele Grüße
Sirenia
AW: jeder schreibt eben ein bisschen anders ...
15.09.2009 10:01:33
Tino
Hallo,
das kommt davon weil ich meist davon ausgehe, dass der Bereich eine Überschrift besitzt.
ok. ist keine Überschrift vorhanden, gehts so.
Private Sub sortieren_Click()
Dim lngRow As Long
Dim varRow
    With Sheets("M")
      
         lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
         
         If lngRow > 9 Then
            varRow = Application.Match(CLng(.Cells(7, 1)), .Range(.Cells(10, 1), .Cells(lngRow, 1)), 0)
            
            If IsNumeric(varRow) Then
             If MsgBox("Datum '" & .Cells(7, 1) & "' schon vorhanden. Wirklich überschreiben?", vbYesNo) = vbNo Then
              Exit Sub
             End If
            End If
          
          End If
        
          .Rows(7).Copy
        
        If IsNumeric(varRow) And lngRow > 9 Then
         .Cells(9 + varRow, 1).PasteSpecial xlPasteValues 'Überschreiben 
        Else
          If lngRow < 11 Then lngRow = 10
         .Cells(lngRow, 1).PasteSpecial xlPasteValues 'neue Zeile 
        End If
        
        Application.CutCopyMode = False
        
        .Range(.Cells(10, 1), .Cells(lngRow, 136)).Sort key1:=.Cells(10, 1), order1:=xlAscending, Header:=xlNo

    End With
  
End Sub
Gruß Tino
Anzeige
stimmt...
15.09.2009 09:04:04
Tino
Hallo,
wenn die Zeile bei Ja wirklich überschrieben werden soll, müsste es so funktionieren.
Private Sub sortieren_Click()
Dim lngRow As Long
Dim varRow
    With Sheets("M")
      
        lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        varRow = Application.Match(CLng(.Cells(7, 1)), .Range(.Cells(10, 1), .Cells(lngRow, 1)), 0)
        
        If IsNumeric(varRow) Then
         If MsgBox("Datum '" & .Cells(7, 1) & "' schon vorhanden. Wirklich überschreiben?", vbYesNo) = vbNo Then
          Exit Sub
         End If
        End If
        
        
        .Rows(7).Copy
        
        If IsNumeric(varRow) Then
         .Cells(9 + varRow, 1).PasteSpecial xlPasteValues 'Überschreiben 
        Else
         .Cells(lngRow, 1).PasteSpecial xlPasteValues 'neue Zeile 
        End If
        
        Application.CutCopyMode = False
        
        .Range(.Cells(10, 1), .Cells(lngRow, 136)).Sort key1:=.Cells(10, 1), order1:=xlAscending, Header:=xlNo

    End With
  
End Sub
Gruß Tino
Anzeige
Klasse :-)
15.09.2009 09:11:40
Sirenia
Klappt wunderbar! Ich danke dir tausendfach! :)
ja habe Antwort gegeben. oT.
15.09.2009 10:02:18
Tino

Links zu Excel-Dialogen

CommandButton

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige