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