Ergänzung VBA Script um zwei IF Abfragen
20.09.2017 09:21:26
Christian
Ich habe ein VBA Sctript, welches mir aufgrund einer Abfrage (Monat) alle Datensätze aus Tabelle 1(Cube_Rohdaten) in Tabelle 2 (Cube_Filter) schreibt.
Nun brauche ich aber noch zwei weitere Abfragen in diesem VBA. Und zwar wenn das Datum (aus Spalte 3) stimmt, und wenn in der betreffenden Zeile in Spalte 8 der Wert "10" steht, und zugleich in Spalte 9 der Wert "Sendungen"
Nur wenn diese drei Bedingungen erfüllt sind, sollte die Zeile kopiert werden.
ich kriegs nicht hin auch nach 2 Tagen Recherche. "If und Else sind definitiv nicht meine Freunde"
-----------------------------------------------------------------------------
Sub Abrechnung_je_Monat()
Dim c As Range, ErgBereich As Range, _
Mon As String, _
einheit As String, _
RP As String, _
laR As Long, _
check As Boolean
Workbooks("Kalkulation_Copyshop - Kopie.xlsm").Worksheets("Cube_Filter").Range("A2:A2000"). _
_
_
EntireRow.Delete
Worksheets("Cube_Rohdaten").Activate
Mon = InputBox(vbCr & vbCr & vbCr & "Bitte den Monat eingeben, für den die Abrechnung _
erzeugt werden soll (1 - 12)" & vbNewLine & vbNewLine & " Der Lauf kann bis zu 5 Sekunden _
dauern")
If Mon = "" Then check = True
If IsNumeric(Mon) Then
If Mon 12 Then check = True
Else
check = True
End If
If check = True Then
MsgBox "Keine oder falsche Eingabe !" & vbCr & vbCr & _
"Bitte wiederholen mit den richtigen Eingaben", vbOKOnly + vbCritical, _
"Dezenter Hinweis für " & Application.UserName & ":"
Exit Sub
End If
Application.ScreenUpdating = False
laR = Cells(Rows.Count, 3).End(xlUp).Row
For Each c In Range("A3:K" & laR)
If IsDate(c.Text) Then
If Month(CDate(c.Text)) = Mon Then
Set ErgBereich = Rows(c.Row)
Exit For
End If
End If
Next c
If ErgBereich Is Nothing Then
MsgBox "Es wurden keine Daten für den Monat " & Mon & " gefunden!", vbOKOnly + _
vbInformation, _
"Dezenter Hinweis für " & Application.UserName & ":"
Else
For Each c In Range("A3:K" & laR)
If IsDate(c.Text) Then
If Month(CDate(c.Text)) = Mon Then
Set ErgBereich = Application.Union(ErgBereich, Rows(c.Row))
End If
End If
Next c
ErgBereich.copy
ActiveSheet.Paste Destination:=Worksheets("Cube_Filter").Range("A3:K200")
MsgBox ("Die Abrechnungsdaten wurden erzeugt. Die Daten wurden in die Tabelle:" & _
vbNewLine & "[Datenlieferung_ITGBA01_Kopier]" & vbNewLine & "geschrieben")
End If
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set ErgBereich = Nothing
Worksheets("Datenlieferung_ITGBA01_Kopier").Activate
End Sub
------------------------------------------------------------------
Danke!!!
Christian