Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1620to1624
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
Wenn Dann auf Spalten anwenden
07.05.2018 20:39:50
Kevin
Wenn Dann VBA
Hallo Zusammen
Dies ist mein erster Beitrag und bin ein Neuling was VBA betrifft!
Habe bereits Stunden in den Foren nach einer passenden Lösung gesucht, jedoch nie das richtige gefunden! Ich hoffe Ihr könnt mir weiterhelfen.
Funktion der Datei:
Der Benutzer (Projektleiter) kann eine Anfrage erfassen.
Sobald die Anfragen getätigt wurden und ein Lieferant bekannt ist, wechselt der Name von AFL(Anfrage Lieferant) auf BS (Bestellung).
Wenn eine Lieferung eingetroffen ist, kann man per dropdown "ok" auswählen, danach wird das Datum eingetragen, die Zelle grün gefärbt und ein Mail geht an den betreffenden Projektleiter.
Da bei jedem neuen Eintrag eine Zeile eingefügt wird, stimmt der Code natürlich nicht mehr: z.B.:
If (Tabelle1.Range("D8").Value) = "Max Muster" Then
Tabelle1.Range("E8").Value = "max.muster@test.ch"
Else
Tabelle1.Range("B1").Value = ""
End If
Grundsätzlich sind meine grössten Anliegen:
  • Wie spricht man eine ganze Spalte an ("A:A")?

  • Wie führt man ein Makro nur ein einziges Mal aus?
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)?

  • Vielen Dank für eure Hilfe bereits im Voraus.
    Falls Ihr noch einige Angaben benötigt, gebt bitte Bescheid.
    Liebe Grüsse
    Kevin
    Userbild

    10
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Datum
    Anwender
    Anzeige
    AW: Wenn Dann auf Spalten anwenden
    08.05.2018 08:29:28
    UweD
    Hallo
    - Bilder sind zwar ok, aber keiner (ich nicht) baut deine Datei nach, um was zu testen?
    - Wodurch wird die Userform geöffnet?
    - was wird mit "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" denn ausgelöst?
    - Mit folgendem code kannst du die erste freie Zeile (LR) in einer Spalte ermittelt und dann dort einfügen
    
    With Sheets("Tabelle1")
    LR = .Cells(.Rows.Count, "B").End(xlUp).Row +1
    End with
    

    LG Uwe D
    AW: Wenn Dann auf Spalten anwenden
    08.05.2018 16:04:08
    Kevin
    Hallo Uwe
    Dankeschön für deine Nachricht.
    Anbei das Excel-File, dann erklärt sich mein Problem automatisch! :P
    https://www.herber.de/bbs/user/121509.xlsx
    Anzeige
    kein Makro drin...
    08.05.2018 17:11:52
    UweD
    leider erklärt sich NICHTS
    LG Uwed
    AW: Wenn Dann auf Spalten anwenden
    08.05.2018 20:16:49
    Kevin
    Hallo Uwe
    Entschuldigung..Nun sollte es klappen mit den Makros:
    https://www.herber.de/bbs/user/121510.xlsm
    - Mit dem CommandButton "Neue Anfrage / Bestellung" wird das Userform geöffnet:Dateneingabe
    - Mit dem CommandButton "Eingabe" wird unter der Zeile "7" eine weitere Zeile eingefügt mit den Werten aus dem UserForm "Bestellung-Erfassen".
    - Nach einiger Zeit sind ja mehrere Anfragen/Bestellungen erfasst, d.h. dass die Codes im VBA nun nicht mehr auf die aktuelle Zeile funktionieren.
    - Wenn man bei Ware bestellt "ok" (H8) auswählt, wird das Datum in (I8) eingefügt und (I8) wird grün.
    - Wenn man bei Ware eingetroffen"ok" (J8) auswählt, wird das Datum in (K8) eingefügt,(I8) + (A8) werden grün und Outlook öffnet sich mit der Mailadresse aus der aktiven Zeile.
    - Wenn das heutige Datum grösser ist als "Lieferdatum" wird automatisch ein Mail an die betroffene Adresse in der Zeile gesendet
    - All dies funktioniert auf die Zellen H8, J8 etc., aber halt nur solange die Eingaben in der 8. Zeile stehen.
    - mit "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" möchte ich erreichen, dass die If-Funktion dauernd funktioniert, sobald ein Name eingegeben wird, muss automatisch die dazugehörige Mail-Adresse eingetragen werden.
    Jedoch ruft dies dauernd die Makros ab, d.h. solange z.B. "ok" steht, öffnet sich bei jedem Klick das Mail-Fenster.
    Hoffentlich kannst du mir weiterhelfen, bin am verzweifeln!
    Anzeige
    AW: Wenn Dann auf Spalten anwenden
    09.05.2018 11:16:01
    UweD
    Hallo
    habe deinen Code an einigen Stellen umgebaut. Sieh es dir mal an.
    Microsoft Excel Objekt DieseArbeitsmappe
    Private Sub Workbook_Open() 
        UserForm1.Show 
    End Sub 
     
     
    Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
        If Date > Worksheets("tabelle1").Range("B4").Value Then 
            Dim outlAnw As Object 
            Dim olAnw As Object 
            Dim Adressaten As String 
               
            Adressaten = "max.muster@test.ch" 
               
            Set outlAnw = CreateObject("Outlook.Application") 
            Set olAnw = outlAnw.CreateItem(0) 
              
            With olAnw 
                ' EMailadresse 
                .To = "" 
                 
                .Subject = "Soeben wurden neue Daten erfasst: " & Date & ", " & Time 
                 
                ' Text 
                .Body = "INFOS " & vbCrLf & vbCrLf & _
                        "Projekt-Nr.: " & Range("B8").Value & vbCrLf & vbCrLf & _
                        "Projektname: " & Range("C8").Value & vbCrLf & vbCrLf & _
                        "Datum: " & Range("E8").Value & vbCrLf & vbCrLf & _
                        "Abteilung: " & Range("A8").Value & vbCrLf & vbCrLf & _
                        "Sachbearbeiter: " & Range("D8").Value & vbCrLf & vbCrLf & _
                        "Rubrik: " & Range("F8").Value & vbCrLf & vbCrLf & _
                        "Bauteil: " & Range("G8").Value & vbCrLf & vbCrLf & _
                        "Beschreibung: " & Range("H8").Value & vbCrLf & vbCrLf & _
                        "Datei-Name: " & Range("I8").Value & vbCrLf & vbCrLf & _
                        "Datei-Format: " & Range("J8").Value & vbCrLf & vbCrLf & _
                        "Fehler-Kategorie: " & Range("K8").Value & vbCrLf & vbCrLf & _
                        "Fehlerursache: " & Range("L8").Value & vbCrLf & vbCrLf & _
                        "Vorschlag zur Vermeidung: " & Range("M8").Value & vbCrLf & vbCrLf & _
                        "Mitteilung: " & Range("N8").Value 
                         
                 
                ' nur wenn Datei angehängt 
                '.Attachments.Add "C:\test.xls", olByValue, 1, "NamederDatei" 
                 
                '.CC = "Email@Adresse" ' hier EMailadresse anpassen 
                '.BCC = "Email@Adresse" ' " 
                 
                .Display 'Outlook-Fenster vor dem Senden anzeigen 
                '.send '= sendet sofort ohne Mail anzuzeigen 
            End With 
             
            Set outlAnw = Nothing: Set olAnw = Nothing 
        End If 
     
    End Sub 
     
    
    Microsoft Excel Objekt Tabelle1
    Private Sub Workbook_Open() 
        UserForm1.Show 
    End Sub 
     
     
    Private Sub CommandButton1_Click() 
        UserForm2.Show 
    End Sub 
     
     
    Private Sub CommandButton2_Click() 
        TextBox1.Select 
    End Sub 
     
     
    Private Sub CommandButton3_Click() 
        Dim TB, LR As Double 
        Set TB = ActiveWorkbook.Sheets("Tabelle1") 
        LR = TB.Cells(TB.Rows.Count, "C").End(xlUp).Row 'letzte Zeile der Spalte 
     
        For i = 8 To LR 
            If TB.Cells(i, 8) = "ok" Then 
                TB.Cells(i, 1).Interior.ColorIndex = 50 
            Else 
                TB.Cells(i, 8).ClearContents 
            End If 
        Next 
    End Sub 
     
     
    Private Sub TextBox1_LostFocus() 
      Dim wks As Worksheet, Wert, Zelle As Range, Nach As Range 
        Set wks = Worksheets("Tabelle1") 
        Wert = Me.TextBox1.Value 
        With wks.Range("C:C") 
            Set Zelle = .Find(what:=Wert, LookIn:=xlValues, lookat:=xlWhole) 
            Do Until Zelle Is Nothing 
                Set Nach = Zelle.Offset(1, 0) 
                Zelle.EntireRow.Delete 
                Set Zelle = .FindNext(After:=Nach) 
            Loop 
        End With 
    End Sub 
     
     
    Private Sub Worksheet_Change(ByVal Target As Range) 
        On Error GoTo Fehler 
         
        Dim strMail As String, strDom As String 
        strDom = "@test.ch" 
         
        If Target.Count > 1 Then Exit Sub ' Zellen nur einzeln bearbeiten 
        If Target.Row < 8 Then Exit Sub 
         
        'mail einfügen bei Änderung in Spalte D Erfasser 
        Application.EnableEvents = False 
        If Target.Column = 4 Then 
             
            If Target <> "" Then 
                strMail = LCase(Replace(Target.Value, " ", ".") & strDom) 
                Target.Offset(0, 1) = strMail 
            Else 
                Target.Offset(0, 1).ClearContents 
            End If 
             
        End If 
         
        'OK in H 
        If Target.Column = 8 Then 
            If Target = "ok" Then 
                ' Datum einfügen 
                Target.Offset(0, 1) = Now 
                Target.Offset(0, 1).Interior.ColorIndex = 50 
             
                ' AFL ersetzen 
                Target.Offset(0, -2).Replace "AFL", "BS", xlPart 
            Else 
                Target.Offset(0, 1).ClearContents 
            End If 
        End If 
             
             
        'OK in J 
        If Target.Column = 10 Then 
            If Target = "ok" Then 
                ' Datum einfügen 
                Target.Offset(0, 1) = Now 
                Target.Offset(0, 1).Interior.ColorIndex = 50 
                Target.Offset(0, -9).Interior.ColorIndex = 50 
                 
                 
                ' Mail senden 
                Dim outlAnw As Object 
                Dim olAnw As Object 
                Dim Adressaten As String 
                   
                Adressaten = Cells(Target.Row, 5) 
                   
                Set outlAnw = CreateObject("Outlook.Application") 
                Set olAnw = outlAnw.CreateItem(0) 
                              
                With olAnw 
                ' EMailadresse 
                .To = Adressaten 
                ' Betreffzeile 
                .Subject = "Soeben ist eine Lieferung eingegangen: " & Date & ", " & Time 
                 
                ' Text 
                .Body = "INFOS " & vbCrLf & vbCrLf & _
                        "Datum: " & Range("B8").Value & vbCrLf & vbCrLf & _
                        "Projekt-Nr.: " & Range("C8").Value & vbCrLf & vbCrLf & _
                        "Sachbearbeiter: " & Range("D8").Value & vbCrLf & vbCrLf & _
                        "Rubrik: " & Range("F8").Value & vbCrLf & vbCrLf & _
                        "Liefertermin: " & Range("K8").Value & vbCrLf & vbCrLf & _
                        "Mitteilung: " & Range("N8").Value 
                         
                 
                ' nur wenn Datei angehängt 
                '.Attachments.Add "C:\test.xls", olByValue, 1, "NamederDatei" 
                 
                '.CC = "Email@Adresse" ' hier EMailadresse anpassen 
                '.BCC = "Email@Adresse" ' " 
                 
                .Display 'Outlook-Fenster vor dem Senden anzeigen 
                '.send '= sendet sofort ohne Mail anzuzeigen 
                End With 
                 
                Set outlAnw = Nothing: Set olAnw = Nothing 
                 
                 
                Else 
                    Target.Offset(0, 1).ClearContents 
                End If 
        End If 
             
             
        '*** Fehlerbehandlung 
        Err.Clear 
    Fehler: 
        Application.EnableEvents = True 
        If Err.Number <> 0 Then MsgBox "Fehler: " & _
            Err.Number & vbLf & Err.Description: Err.Clear 
    End Sub 
    
    Dialog UserForm1
    Private Sub CommandButton3_Click() 
        Sheets("001").Activate 
        MsgBox "Bitte beim Feld Datei-Namen einen eindeutigen Namen eingeben", vbOKOnly, "Hinweis Datenerfassung" 
        Unload UserForm2 
        UserForm2.Show 
        TextBox3 = Date 
    End Sub 
     
     
    Private Sub CommandButton1_Click() 
        MsgBox "Lieferdatum = Lieferung im Haus", vbOKOnly, "Hinweis Datenerfassung" 
        Unload UserForm1 
        UserForm2.Show 
    End Sub 
     
     
     
    
    Dialog UserForm2
     
    Private Sub CommandButton1_Click() 
        On Error GoTo Fehler 
        Application.EnableEvents = False 
         
        ThisWorkbook.Worksheets("Tabelle1").Rows("7:7").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 
        ThisWorkbook.Worksheets("Tabelle1").Range("B8").Value = Me.TextBox1.Value 
        ThisWorkbook.Worksheets("Tabelle1").Range("C8").Value = Me.TextBox4.Value 
        ThisWorkbook.Worksheets("Tabelle1").Range("G8").Value = Me.TextBox6.Value 
        ThisWorkbook.Worksheets("Tabelle1").Range("F8").Value = Me.ComboBox1.Value 
         
        Application.EnableEvents = True 
        ThisWorkbook.Worksheets("Tabelle1").Range("D8").Value = Me.ComboBox2.Value 
        Unload Me 
         
        '*** Fehlerbehandlung 
        Err.Clear 
    Fehler: 
        Application.EnableEvents = True 
        If Err.Number <> 0 Then MsgBox "Fehler: " & _
            Err.Number & vbLf & Err.Description: Err.Clear 
    End Sub 
     
     
    Private Sub CommandButton2_Click() 
        Unload Me 
    End Sub 
     
     
    Private Sub TextBox1_Enter() 
        TextBox1.Text = Date 
    End Sub 
     
     
    Private Sub UserForm_Initialize() 
        With Me.ComboBox1 
            .AddItem "" 
            .AddItem "AFL" 
            .AddItem "AFL_Blech" 
            .AddItem "AFL_Duplex" 
            .AddItem "AFL_Elox" 
            .AddItem "AFL_Glas" 
            .AddItem "AFL_Gutmann" 
            .AddItem "AFL_Hueck" 
            .AddItem "AFL_Klebit" 
            .AddItem "AFL_Kran" 
            .AddItem "AFL_KVT-Lager" 
            .AddItem "AFL_Lack" 
            .AddItem "AFL_Pestalozzi" 
            .AddItem "AFL_Peterhans" 
            .AddItem "AFL_SIGA" 
            .AddItem "AFL_Stahl" 
            .AddItem "AFL_Strahm" 
            .AddItem "AFL_Zink" 
            .ListIndex = 0 'Vorbelegung "Arbeitsablauf" bei Formularstart 
        End With 
     
        With Me.ComboBox2 
            .AddItem "" 
            .AddItem "Max Muster1" 
            .AddItem "Max Muster2" 
            .AddItem "Max Muster3" 
            .ListIndex = 0 'Vorbelegung "Arbeitsablauf" bei Formularstart 
        End With 
    End Sub 
    
    Dialog UserForm3
    Private Sub CommandButton1_Click() 
        ThisWorkbook.Worksheets("Tabelle1").Range("L8").Value = Me.TextBox1.Value 
        Unload Me 
    End Sub 
    
    Modul1
    Option Explicit 
     
    Public Sub VerfallDatum() 
     
        Dim WkSh As Worksheet 
        Dim lZeile As Long 
         
        With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen! 
            ' die Spalte 1 = G ab Zeile 1 bis Ende abarbeiten 
            For lZeile = 1 To .Cells(Rows.Count, 2).End(xlUp).Row 
                ' ist die Zelle NICHT leer? 
                If Trim(.Range("G" & lZeile).Value) <> "" Then 
                    ' steht in der Zelle ein Datum? 
                    If IsDate(.Range("G" & lZeile).Value) Then 
                        ' ist das Datum kleiner als das Tagesdatum? 
                        If CDate(.Range("G" & lZeile).Value) < Date Then 
                            MsgBox "Die Lieferung des Projektes ""G" & lZeile & """ ist nicht " & _
                                "eingetroffen.", 48, " Hinweis für " & Application.UserName 
                        End If 
                    End If 
                End If 
            Next lZeile 
        End With 
     
    End Sub 
     
     
     
     
     
    
    Modul2
    Private Sub LieferantHinzufuegen() 
        If (Tabelle1.Range("H8").Value) = "ok" Then 
            UserForm3.Show 
        Else 
            Tabelle1.Range("H8").ClearContents 
        End If 
    End Sub 
     
    
    Modul7
    Sub Schaltfläche8_Klicken() 
        Range("A7:K7").AutoFilter 
    End Sub 
     
     
    Sub Schaltfläche9_Klicken() 
        Range("A7:K7").AutoFilter 
    End Sub 
    

    LG UweD
    Anzeige
    AW: Wenn Dann auf Spalten anwenden
    09.05.2018 13:31:51
    Kevin
    Hallo Uwe
    Ich danke dir von Herzen für die Überarbeitung des Codes! Es funktioniert super!
    Nun möchte ich noch die UserForm3 öffnen und anschliessend den Text aus der Textbox des Userforms "z.B. Musterlieferant" in die aktive Zeile Spalte ("L") einsetzen
     'OK in H
    If Target.Column = 8 Then
    If Target = "ok" Then
    ' Datum einfügen
    Target.Offset(0, 1) = Now
    Target.Offset(0, 1).Interior.ColorIndex = 50
    UserForm3.Show
    ' AFL ersetzen
    Target.Offset(0, -2).Replace "AFL", "BS", xlPart
    Else
    Target.Offset(0, 1).ClearContents
    End If
    End If 
    
    Zudem möchte ich das heutige Datum mit den Lieferdaten aus der Spalte ("G") vergleichen, falls das heutige Datum > als eines der Lieferdaten, soll automatisch ein Mail an den betroffenen Projektleiter (aus der Zeile des überschrittenen Datums) gesendet werden; Als Betreff soll stehen: Die Lieferung für das Projekt "z.B. 160121" ist nicht eingetroffen. Dieses Makro muss ja ständig ausgeführt werden oder bei WorkbookOpen?
    Kannst du mir für die zwei weiteren Punkte nochmals weiterhelfen?
    Der Code "Target.Offset(0, 1)" hat mir sehr geholfen! Hast du allgemein noch einen guten Tipp für mich?
    Vielen Dank und Gruss
    Anzeige
    AW: Wenn Dann auf Spalten anwenden
    09.05.2018 14:15:03
    UweD
    Hallo
    zu 1
    zu 2
    - ich habe ein PublicVariable im ersten Modul definiert, die steht dann für alle Makros zu Verfügung
    
    Option Explicit
    Public Lieferant As String
    Public Sub VerfallDatum()
    

    - Beim Erfassen in der Box wird dann nicht sofort in eine Fixe Reihe geschrieben, sondern die Variable belegt
    Dialog UserForm3
    Private Sub CommandButton1_Click() 
        Lieferant = Me.TextBox1.Value 
        Unload Me 
    End Sub 
    
    - anschließend dann im Hauptmakro erst in die aktuelle Zeile in Spalte L eingetragen
        If Target.Column = 8 Then
            If Target = "ok" Then
                ' Datum einfügen 
                Target.Offset(0, 1) = Now
                Target.Offset(0, 1).Interior.ColorIndex = 50
                UserForm3.Show
                Target.Offset(0, 4) = Lieferant
                ' AFL ersetzen 
                Target.Offset(0, -2).Replace "AFL", "BS", xlPart
            Else
                Target.Offset(0, 1).ClearContents
            End If
        End If
    

    LG UweD
    Anzeige
    AW: Wenn Dann auf Spalten anwenden
    09.05.2018 14:47:23
    Kevin
    Das funktioniert auch einwandfrei, vielen Dank!
    Muss mich nun mit deinen Anpassungen auseinandersetzen, damit ich dies alles genau nachvollziehen kann!
    Das Makro zu folgendem Wunsch hat es mir nicht angezeigt? (1)
    "Zudem möchte ich das heutige Datum mit den Lieferdaten aus der Spalte ("G") vergleichen, falls das heutige Datum grösser als eines der Lieferdaten, soll automatisch ein Mail an den betroffenen Projektleiter (aus der Zeile des überschrittenen Datums) gesendet werden; Als Betreff soll stehen: Die Lieferung für das Projekt "z.B. 160121" ist nicht eingetroffen."
    zu 1)
    09.05.2018 14:46:20
    UweD
    das mailsenden als Unterprogramm vorsehen und die Variablen beim Aufrufen übergeben . Das machst du überall, wo du was verschicken möchtest
    in ein Modul
    
    Sub mail_senden(strTo, StrSub, StrBody) 'weitere Variable bei Bedarf
    Dim outlAnw As Object
    Dim olAnw As Object
    Set outlAnw = CreateObject("Outlook.Application")
    Set olAnw = outlAnw.CreateItem(0)
    With olAnw
    ' EMailadresse
    .To = strTo
    .Subject = StrSub
    ' Text
    .Body = StrBody
    ' nur wenn Datei angehängt
    '.Attachments.Add "C:\test.xls", olByValue, 1, "NamederDatei"
    '.CC = "Email@Adresse" ' hier EMailadresse anpassen
    '.BCC = "Email@Adresse" ' "
    .Display 'Outlook-Fenster vor dem Senden anzeigen
    '.send '= sendet sofort ohne Mail anzuzeigen
    End With
    Set outlAnw = Nothing: Set olAnw = Nothing
    End Sub
    

    in DieseArbeitsmappe dann z.B.
    
    Private Sub Workbook_Open()
    Dim TB, i As Double, LR As Double, SP As Integer
    Dim strTo, StrSub, StrBody
    Set TB = ActiveWorkbook.Sheets("Tabelle1")
    SP = 7 'Spalte G
    LR = TB.Cells(TB.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
    For i = 8 To LR
    With TB.Cells(i, SP)
    If .Value 

    Den Rest bitte selber machen.
    Langes Wochenende..
    LG UweD
    Anzeige
    AW: zu 1)
    09.05.2018 15:04:24
    Kevin
    Herzlichen Dank Uwe, du hast mir richtig geholfen!!
    Bin dir wirklich sehr dankbar!
    Ich wünsche dir ein schönes langes Wochenende! ;)
    Hoffentlich darf ich beim nächsten Anliegen wieder auf dich zukommen.
    LG Kevin

    300 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige