Hilfe bei Excel Macro

tm · 13.06.2006

Hi Matjes,

ich traue mich gar nicht mehr fragen,
aber ich hätte noch etwas. Es wäre das i-tüpfelchen, sozusagen.
Ehrlich gesagt, hatte ich nicht mit so einer Profi-Arbeit !! gerechnet, darum hatte ich Anfangs klein angefangen.
Aber wenn sich nachfolgendes nicht auch so mal in der Halbzeitpause erledigen läßt,
dann bin ich auch mit dem sehr Zufrieden, was ich habe. Und außerdem opferst Du ja schließlich auch Deine Freizeit !
Du weist, ja, hat man mal einen Profi zur Hand, dann ......, tja dann will man ihn nicht mehr auslassen ! ;D

Es gibt noch eine Spalte F,
Formatierung: Benutzerdefiniert, Format: hh:mm,
und hat z. B. einen Wert von 00:02 (also 0 Stunden und 2 Minuten).

bei der Klassifizierung Werktag / Nicht Werktag, müsste nun eigentlich folg. berücksichtigt werden:
wenn die Spalte B nun z. B. folg. ausweist:
09.09.06 08:59:00 und in der Spalte F z. B. 00:10 stehen würde,
dann wird bisher die Zeile in Script 2 ausgewertet.

eigentlich dürfte im Script 2 (ZeileLoeschenWennDatumZeitInSpalteBWerktags9bis18Uhr)
die Zeile dann nur mit 1 Minute erscheinen und im Spcript 1 die gleiche Zeile mit den restlichen 9 Minuten
(da ja nach 1 Minute 09:00:00 erreicht wäre, und somit das ganze eben
hier (ZeileLoeschenWennDatumZeitInSpalteBNichtWerktags9bis18Uhr) drunter fallen müsste.

?? :T

Matjes · 13.06.2006

Hallo tm,

daß hiesse dann, daß in diesen Grenzfällen in Spalte B auch der Zeitpunkt geändert werden müßte , wenn die Zeit durch den jetzt zusätzlichen offset über die Grenzzeit hinausragt /hineinragt ?

Gruß Matjes

tm · 13.06.2006

in der ausgangsliste würde in der spalte b manuell nichts verändert werden.
es würde also reichen, falls es geht, das das script das erledigen könnte
(es ist so, das es eine ausgangsliste gibt, dann läuft das script, und dann werden die entsprechenden zeilen
in ein weiteres formular (mit summen, etc.) kopiert.

also das script selbst müsste nix ändern, sondern es würde reichen, wenn nur die jeweils entsprechenden
zeilen da stehen, nach aufruf des scripts.

??

Matjes · 13.06.2006

zu Makro Excel_ZeileLoeschenWennDatumZeitInSpalteBNichtWerktags9bis18Uhr:
Der Makro löscht jetzt die Zeile, wenn Zeitpunkt in Spalte B nicht Werktags900bis1800Uhr ist.

a) Zeitpunkt Mo 8:58, Offset 00:05
->Zeile nicht löschen ??
b) Zeitpunkt Mo 17:58 Offset 00:05
-> Zeile nicht löschen ??

zu Makro Excel_ZeileLoeschenWennDatumZeitInSpalteBWerktags9bis18Uhr
Der Makro löscht jetzt die Zeile, wenn Zeitpunkt in Spalte B Werktags900bis1800Uhr ist.

c) Zeitpunkt Mo 8:58, Offset 00:05
->Zeile löschen ?? oder nicht ?
d) Zeitpunkt Mo 17:58 Offset 00:05
-> Zeile löschen ?? oder nicht ??

Gruß Matjes

tm · 13.06.2006

ah, ich glaube ich hab´s doch falsch beschrieben,
auch bezüglich der werte bzw. deren änderungen; sorry

zu Makro Excel_ZeileLoeschenWennDatumZeitInSpalteBNichtWerktags9bis18Uhr:
Der Makro löscht jetzt die Zeile, wenn Zeitpunkt in Spalte B nicht Werktags900bis1800Uhr ist.

a) Zeitpunkt Mo 8:58, Offset 00:05
->Zeile nicht löschen ??
b) Zeitpunkt Mo 17:58 Offset 00:05
-> Zeile nicht löschen ??

zu Makro Excel_ZeileLoeschenWennDatumZeitInSpalteBWerktags9bis18Uhr
Der Makro löscht jetzt die Zeile, wenn Zeitpunkt in Spalte B Werktags900bis1800Uhr ist.

c) Zeitpunkt Mo 8:58, Offset 00:05
->Zeile löschen ?? oder nicht ?
d) Zeitpunkt Mo 17:58 Offset 00:05
-> Zeile löschen ?? oder nicht ??

------------------------------------------------------------
ich gehe von folg. ausganswerten aus:
...08:58:00 Wert SpalteF 00:05 (5 Minuten); würde jetzt in alt script 2 ausgewertet werden
...17:58:00 Wert SpalteF 00:05 (5 Minuten); würde jetzt in alt script 1 ausgewertet werden

NEU
bei a) müsste das ergebnis der zeile sein,
also Zeile nicht löschen, aber:
... 08:58:..... SpalteF 00:03
bei b) müsste das ergebnis der zeile sein,
also Zeile nicht löschen, aber:
... 17:58:..... SpalteF 00:02

bei c) müsste das ergebnis der zeile sein,
also Zeile nicht löschen, aber:
... 08:58:.... SpalteF 00:02
bei d) müsste das ergebnis der zeile sein,
also Zeile nicht löschen, aber:
... 17:58:..... SpalteF 00:03

am saubersten wäre natürlich schon, wie von dir schon angedeutet,
wenn in diesem beispiel, jetzt neu bei
a) stehen würde (da ja auch erst ab 09.00 Uhr das ganze sozusagen wirkt)
... 09:00..... SpalteF 00:03

und bei d) (und ja auch hier lt. Regel erst ab 18.00 Uhr)
... 18:00..... SpalteF 00:03

aber ich weis nicht, ob das jetzt nicht alles zu kompliziert wird, u. a. wenn da jetzt auch noch Änderungen gemacht
werden müssten, was die werte in spalteB betrifft ??
wie siehst du das ??

Matjes · 13.06.2006

Hallo tm,

damit ist schon mal sauber definiert was passieren soll

Ich schau mir das heute abend an. Eventuell bau ich dir dann einen Schalter ein mit/ohne Modifizieren SpalteB.

Gruß Matjes

tm · 13.06.2006

Matjes schrieb:
Eventuell bau ich dir dann einen Schalter ein mit/ohne Modifizieren SpalteB.

das wäre natürlich überirdisch !! :T

ich sehe schon an dir kommt einer vorbei !!
z. b. auch hinsichtlich des telefonfilters, den du schon, vermutlich in weiser voraussicht variabel von der länge her gestaltet hast.
habs schon getestet, funktioniert super.
so kann ich beispielsweise noch reagieren, wenn sich mit den vorlauf nullen noch etwas tut !!

danke !!!

aber es muss keinesfalls noch heute sein !!!

gruss
tm

Matjes · 13.06.2006

Heute hat es etwas länger als die Halbzeitpause gedauert ;D

Schalter ist eingebaut.

Gruß Matjes

Code:

Option Explicit
Private Const cSPDATETIME = 2     'Spalte Datum/Zeit
Private Const cSPTELNR = 3       ->Spalte Telefonnummer
Private Const cSPTIMEOFFSET = 6   'Spalte Zeitoffset
Private Const cZUEBERCHRIFT = 1   'Zeile Überschrift

'Werden die Zeitgrenzen 9:00 bzw. 18:00 durch den Offset überschritten
'werden die Zeit(DATETIME) und der ZeitOffset angepasst, wenn
'der folgende Schalter auf True steht.
'bei False werden bleiben beide Werte unverändert
Private Const cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN = True



'********************************************************************
Sub Excel_ZLoeNichtWerktags9bis18Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDateTime As Date, dTimeOffset As Date
  Dim bZeitGrenzeDurchOffset As Boolean
  Dim b9UhrGrenze As Boolean
  Dim dDateTime859 As Date, dDiffDateTimeBis859 As Date
  Dim dDateTime900 As Date, dDiffDateTimeAb900 As Date
  Dim b18UhrGrenze As Boolean
  Dim dDateTime1800 As Date, dDiffDateTimeBis1800 As Date
  Dim dDateTime1801 As Date, dDiffDateTimeAb1801 As Date
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To cZUEBERCHRIFT + 1 Step -1
    sTelNr = ActiveSheet.Cells(lZeile, cSPTELNR).Value
    If TelefonNummernfilter(sTelNr) Then
     ->gefilterte Telnummern auf jeden Fall löschen
      ActiveSheet.Rows(lZeile).Delete
    Else
     ->Zeilen ohne Datum überspringen
      If IsDate(ActiveSheet.Cells(lZeile, cSPDATETIME).Value) Then
        dDateTime = ActiveSheet.Cells(lZeile, cSPDATETIME).Value
        dTimeOffset = ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value
        If Not WerktagsVon09Bis1800(dDateTime, dTimeOffset, _
                                    bZeitGrenzeDurchOffset, _
                                    b9UhrGrenze, _
                                    dDateTime859, dDiffDateTimeBis859, _
                                    dDateTime900, dDiffDateTimeAb900, _
                                    b18UhrGrenze, _
                                    dDateTime1800, dDiffDateTimeBis1800, _
                                    dDateTime1801, dDiffDateTimeAb1801) Then
          If Not bZeitGrenzeDurchOffset Then
            ActiveSheet.Rows(lZeile).Delete
          End If
        End If
        If bZeitGrenzeDurchOffset Then
          If cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN Then
            If b9UhrGrenze Then
              ActiveSheet.Cells(lZeile, cSPDATETIME).Value = dDateTime900
              ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeAb900
            End If
            If b18UhrGrenze Then
              ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeBis1800
            End If
          End If
        End If
      End If
    End If
  Next
End Sub
'********************************************************************
Sub Excel_ZLoeWerktags9bis18Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDateTime As Date, dTimeOffset As Date
  Dim bZeitGrenzeDurchOffset As Boolean
  Dim b9UhrGrenze As Boolean
  Dim dDateTime859 As Date, dDiffDateTimeBis859 As Date
  Dim dDateTime900 As Date, dDiffDateTimeAb900 As Date
  Dim b18UhrGrenze As Boolean
  Dim dDateTime1800 As Date, dDiffDateTimeBis1800 As Date
  Dim dDateTime1801 As Date, dDiffDateTimeAb1801 As Date
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To cZUEBERCHRIFT + 1 Step -1
    sTelNr = ActiveSheet.Cells(lZeile, cSPTELNR).Value
    If TelefonNummernfilter(sTelNr) Then
     ->gefilterte Telnummern auf jeden Fall löschen
      ActiveSheet.Rows(lZeile).Delete
    Else
     ->Zeilen ohne Datum überspringen
      If IsDate(ActiveSheet.Cells(lZeile, cSPDATETIME).Value) Then
        dDateTime = ActiveSheet.Cells(lZeile, cSPDATETIME).Value
        dTimeOffset = ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value
        If WerktagsVon09Bis1800(dDateTime, dTimeOffset, _
                                    bZeitGrenzeDurchOffset, _
                                    b9UhrGrenze, _
                                    dDateTime859, dDiffDateTimeBis859, _
                                    dDateTime900, dDiffDateTimeAb900, _
                                    b18UhrGrenze, _
                                    dDateTime1800, dDiffDateTimeBis1800, _
                                    dDateTime1801, dDiffDateTimeAb1801) Then
          If Not bZeitGrenzeDurchOffset Then
            ActiveSheet.Rows(lZeile).Delete
          End If
        End If
        If bZeitGrenzeDurchOffset Then
          If cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN Then
            If b9UhrGrenze Then
              If Hour(dDiffDateTimeBis859) = 0 And Minute(dDiffDateTimeBis859) = 0 Then
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeBis859
              End If
            End If
            If b18UhrGrenze Then
              ActiveSheet.Cells(lZeile, cSPDATETIME).Value = dDateTime1801
              If Hour(dDiffDateTimeAb1801) = 0 And Minute(dDiffDateTimeAb1801) = 0 Then
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeAb1801
              End If
            End If
          End If
        End If
      End If
    End If
  Next
End Sub
'********************************************************************
Private Function WerktagsVon09Bis1800(dDateTime As Date, dTimeOffset As Date, _
                                      bZeitGrenzeDurchOffset As Boolean, _
                                      b9UhrGrenze As Boolean, _
                                      dDateTime859 As Date, _
                                      dDiffDateTimeBis859 As Date, _
                                      dDateTime900 As Date, _
                                      dDiffDateTimeAb900 As Date, _
                                      b18UhrGrenze As Boolean, _
                                      dDateTime1800 As Date, _
                                      dDiffDateTimeBis1800 As Date, _
                                      dDateTime1801 As Date, _
                                      dDiffDateTimeAb1801 As Date) As Boolean
'***   True, wenn Datum/Zeit Werktags(Mo-Fr) 9:00 bis 18:00 ist
  
  Dim iWochentag As Integer
  Dim iStd As Integer, iMin As Integer, iSec As Integer
  Dim iOffsetStd As Integer, iOffsetMin As Integer
  Dim dDateTime2 As Date
  Dim iWochentag2 As Integer
  Dim iStd2 As Integer, iMin2 As Integer, iSec2 As Integer
  Dim bWerktagsVon09Bis1800 As Boolean
  
  
 ->*** Löschsperre erstmal löschen
  bZeitGrenzeDurchOffset = False
  
 ->*** DateTime
  
  iWochentag = WeekDay(dDateTime)
  iStd = Hour(dDateTime)
  iMin = Minute(dDateTime)
  iSec = Second(dDateTime)
  iOffsetStd = Hour(dTimeOffset)
  iOffsetMin = Minute(dTimeOffset)
  
 ->Werktags9bis18Uhr ? für DateTime
  If IstFeiertag(dDateTime) Then
    WerktagsVon09Bis1800 = False
  ElseIf (iWochentag = vbSaturday) Or (iWochentag = vbSunday) Then
    WerktagsVon09Bis1800 = False
  ElseIf iStd >= 9 And iStd &lt;= 17 Then
    WerktagsVon09Bis1800 = True
  ElseIf iStd = 18 And iMin = 0 And iSec = 0 Then
    WerktagsVon09Bis1800 = True
  Else
    WerktagsVon09Bis1800 = False
  End If
  
 ->*** DateTime + Zeitoffset
  
 ->Zeitoffset auf DateTime addieren -> DateTime2
  dDateTime2 = DateAdd(h, iOffsetStd, dDateTime)->std
  dDateTime2 = DateAdd(n, iOffsetMin, dDateTime2)->min
  iWochentag2 = WeekDay(dDateTime2)
  iStd2 = Hour(dDateTime2)
  iMin2 = Minute(dDateTime2)
  iSec2 = Second(dDateTime2)

 ->Werktags9bis18Uhr ? für DateTime2
  If IstFeiertag(dDateTime2) Then
    bWerktagsVon09Bis1800 = False
  ElseIf (iWochentag2 = vbSaturday) Or (iWochentag2 = vbSunday) Then
    bWerktagsVon09Bis1800 = False
  ElseIf iStd2 >= 9 And iStd2 &lt;= 17 Then
    bWerktagsVon09Bis1800 = True
  ElseIf iStd2 = 18 And iMin2 = 0 And iSec2 = 0 Then
    bWerktagsVon09Bis1800 = True
  Else
    bWerktagsVon09Bis1800 = False
  End If

  b9UhrGrenze = False
  b18UhrGrenze = False
  
 ->Urteil für beide Datum ungleich ?
  If Not (bWerktagsVon09Bis1800 = WerktagsVon09Bis1800) Then
   ->nein -> nicht löschen
    bZeitGrenzeDurchOffset = True
        
   ->Grenze 9:00 bzw. 18:00
    If iStd &lt; 9 And iStd2 >= 9 Then b9UhrGrenze = True Else b18UhrGrenze = True
    
    If b9UhrGrenze Then
     ->datum 9 uhr erzeugen
      dDateTime900 = Format(dDateTime, dd.mm.yyyy)
      dDateTime900 = DateAdd(h, 9, dDateTime900)
     ->datum 8:59 uhr erzeugen
      dDateTime859 = Format(dDateTime, dd.mm.yyyy)
      dDateTime859 = DateAdd(h, 8, dDateTime859)
      dDateTime859 = DateAdd(n, 59, dDateTime859)
     ->Differenzen für Offset berechnen
      dDiffDateTimeBis859 = dDateTime859 - dDateTime
      dDiffDateTimeAb900 = dDateTime2 - dDateTime900
    End If
    If b18UhrGrenze Then
     ->datum 18 uhr erzeugen
      dDateTime1800 = Format(dDateTime, dd.mm.yyyy)
      dDateTime1800 = DateAdd(h, 18, dDateTime1800)
     ->datum 18:01 uhr erzeugen
      dDateTime1801 = Format(dDateTime, dd.mm.yyyy)
      dDateTime1801 = DateAdd(h, 18, dDateTime1801)
      dDateTime1801 = DateAdd(n, 1, dDateTime1801)
     ->Differenzen für Offset berechnen
      dDiffDateTimeBis1800 = dDateTime1800 - dDateTime
      dDiffDateTimeAb1801 = dDateTime2 - dDateTime1801
    End If
    
  End If
End Function
'********************************************************************
Private Function IstFeiertag(dDateTime As Date) As Boolean
'***   True, wenn Datum/Zeit Feiertag ist

  Dim FeiertageDatum As Variant
  FeiertageDatum = Array(14.4.2006, 16.4.2006, 17.4.2006, _
                         1.5.2006, 25.5.2006, 4.6.2006, _
                         5.6.2006)
  
  Dim sDatum As String, x As Long
  
  sDatum = Format(dDateTime, d.m.yyyy)
  IstFeiertag = False
  For x = LBound(FeiertageDatum) To UBound(FeiertageDatum)
    If sDatum = FeiertageDatum(x) Then IstFeiertag = True: Exit For
  Next
End Function
Private Function TelefonNummernfilter(sTelNr As String) As Boolean
'***   True, wenn sTelNr mit einem TelNrFilter anfängt

  Dim TelNrFilter As Variant, x As Long
  TelNrFilter = Array(170, 171)

  TelefonNummernfilter = False
  If sTelNr =  Then Exit Function
  For x = LBound(TelNrFilter) To UBound(TelNrFilter)
    If TelNrFilter(x) = Left(sTelNr, Len(TelNrFilter(x))) Then
      TelefonNummernfilter = True: Exit For
    End If
  Next

End Function

tm · 14.06.2006

hi matjes,

leider ist noch ein fehler drin.
vermutlich aber mehr durch meine nicht korrekte beschreibung.

a) wenn das 1. script läuft, dann bleiben auch die zeilen die eigentlich script 2 betreffen stehen
und sind rot markiert.

b) wenn das 2. script läuft, dann bleiben ebenfalls alle zeilen erhalten und die die script 1 betreffen
sind gelb markiert.

für a) und b) ist es egal ob dieser modifizierende schalter auf true oder false steht.
es kommt immer das gleiche ergebnis.

vielleicht bestand bei meiner beschreibung dahingehend das missverständnis,
da ich nur bei den zeilen die diese grenzwerte aufweisen,
gemeint habe, diese müssten dann in beiden scripten, mit ihren entsprechenden werten, ausgewertet werden !?
aber es sollte eigentlich schon im 1. bzw. 2. script nur die auswertung übrigbleiben wie vorher, zuzüglich nur dieser grenzwert zeilen.

c) bei den grenzwerten ist mir auch noch etwas aufgefallen:
wenn z. b. der ausgangswert 08:59 ist und in der dauer, z. b. 00:01 steht,
dann wird daraus 09.00 und die zeile wandert in die andere auswertung.

richtig wäre aber hier, das bei 08:59 und einer dauer von 00:01 die zeile
unverändert in der entsprechneden auswertung bleibt (in diesem beispiel 2. script).
erst bei einer dauer von 00:02 würde
im 2. script nachwievor 08:59 mit einer dauer von 00:01 stehen
und im 1. script 09:00 mit einer dauer ebenfalls von 00:01

das gleiche bei 17:59 / 18:00 Uhr.

Sorry !!

Matjes · 14.06.2006

Hallo tm,

hatte vergessen das Test-Löschen (rot, gelb markiert) gegen das tatsächliche Delete auszutaschen. Ist gefixt.

Die Minuten-rechnung laß ich mir nochmal durch den Kopf gehen.

Gruß Matjes

Matjes · 14.06.2006

Hab dir noch einen Schalter eingebaut, der momentan verhindert, dass Spalte B modifiziert wird. So bleibt jetzt Spalte B unberührt.

Differenz von 1 ist auch gefixt.

Schau mal, ob es jetzt passt.

Gruß Matjes

Code:

Option Explicit
Private Const cSPDATETIME = 2     'Spalte Datum/Zeit
Private Const cSPTELNR = 3       ->Spalte Telefonnummer
Private Const cSPTIMEOFFSET = 6   'Spalte Zeitoffset
Private Const cZUEBERCHRIFT = 1   'Zeile Überschrift

'Werden die Zeitgrenzen 9:00 bzw. 18:00 durch den Offset überschritten
'werden die Zeit(DATETIME) und der ZeitOffset angepasst, wenn
'der folgende Schalter auf True steht.
'bei False werden bleiben beide Werte unverändert
Private Const cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN = True
'dieser Schalter auf false unterdrückt die Änderung von Spalte B (DATETIME)
Private Const cSCHALTER_BEIZEITGRENZE_ZEITEN_SPALTE_B_MODIFIZIEREN = False


'********************************************************************
Sub Excel_ZLoeNichtWerktags9bis18Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDateTime As Date, dTimeOffset As Date
  Dim bZeitGrenzeDurchOffset As Boolean
  Dim b9UhrGrenze As Boolean
  Dim dDiffDateTimeBis900 As Date
  Dim dDateTime900 As Date, dDiffDateTimeAb900 As Date
  Dim b18UhrGrenze As Boolean
  Dim dDateTime1800 As Date, dDiffDateTimeBis1800 As Date
  Dim dDateTime1801 As Date, dDiffDateTimeAb1801 As Date
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To cZUEBERCHRIFT + 1 Step -1
    sTelNr = ActiveSheet.Cells(lZeile, cSPTELNR).Value
    If TelefonNummernfilter(sTelNr) Then
     ->gefilterte Telnummern auf jeden Fall löschen
      ActiveSheet.Rows(lZeile).Delete
    Else
     ->Zeilen ohne Datum überspringen
      If IsDate(ActiveSheet.Cells(lZeile, cSPDATETIME).Value) Then
        dDateTime = ActiveSheet.Cells(lZeile, cSPDATETIME).Value
        dTimeOffset = ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value
        If Not WerktagsVon09Bis1800(dDateTime, dTimeOffset, _
                                    bZeitGrenzeDurchOffset, _
                                    b9UhrGrenze, _
                                    dDiffDateTimeBis900, _
                                    dDateTime900, dDiffDateTimeAb900, _
                                    b18UhrGrenze, _
                                    dDateTime1800, dDiffDateTimeBis1800, _
                                    dDateTime1801, dDiffDateTimeAb1801) Then
          If Not bZeitGrenzeDurchOffset Then
            ActiveSheet.Rows(lZeile).Delete
          End If
        End If
        If bZeitGrenzeDurchOffset Then
          If cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN Then
            If b9UhrGrenze Then
              If cSCHALTER_BEIZEITGRENZE_ZEITEN_SPALTE_B_MODIFIZIEREN Then
                ActiveSheet.Cells(lZeile, cSPDATETIME).Value = dDateTime900
              End If
              ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeAb900
            End If
            If b18UhrGrenze Then
              ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeBis1800
            End If
          End If
        End If
      End If
    End If
  Next
End Sub
'********************************************************************
Sub Excel_ZLoeWerktags9bis18Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDateTime As Date, dTimeOffset As Date
  Dim bZeitGrenzeDurchOffset As Boolean
  Dim b9UhrGrenze As Boolean
  Dim dDiffDateTimeBis900 As Date
  Dim dDateTime900 As Date, dDiffDateTimeAb900 As Date
  Dim b18UhrGrenze As Boolean
  Dim dDateTime1800 As Date, dDiffDateTimeBis1800 As Date
  Dim dDateTime1801 As Date, dDiffDateTimeAb1801 As Date
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To cZUEBERCHRIFT + 1 Step -1
    sTelNr = ActiveSheet.Cells(lZeile, cSPTELNR).Value
    If TelefonNummernfilter(sTelNr) Then
     ->gefilterte Telnummern auf jeden Fall löschen
      ActiveSheet.Rows(lZeile).Delete
    Else
     ->Zeilen ohne Datum überspringen
      If IsDate(ActiveSheet.Cells(lZeile, cSPDATETIME).Value) Then
        dDateTime = ActiveSheet.Cells(lZeile, cSPDATETIME).Value
        dTimeOffset = ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value
        If WerktagsVon09Bis1800(dDateTime, dTimeOffset, _
                                    bZeitGrenzeDurchOffset, _
                                    b9UhrGrenze, _
                                    dDiffDateTimeBis900, _
                                    dDateTime900, dDiffDateTimeAb900, _
                                    b18UhrGrenze, _
                                    dDateTime1800, dDiffDateTimeBis1800, _
                                    dDateTime1801, dDiffDateTimeAb1801) Then
          If Not bZeitGrenzeDurchOffset Then
            ActiveSheet.Rows(lZeile).Delete
          End If
        End If
        If bZeitGrenzeDurchOffset Then
          If cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN Then
            If b9UhrGrenze Then
              If Hour(dDiffDateTimeBis900) = 0 And Minute(dDiffDateTimeBis900) = 0 Then
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeBis900
              End If
            End If
            If b18UhrGrenze Then
              If cSCHALTER_BEIZEITGRENZE_ZEITEN_SPALTE_B_MODIFIZIEREN Then
                ActiveSheet.Cells(lZeile, cSPDATETIME).Value = dDateTime1801
              End If
              If Hour(dDiffDateTimeAb1801) = 0 And Minute(dDiffDateTimeAb1801) = 0 Then
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeAb1801
              End If
            End If
          End If
        End If
      End If
    End If
  Next
End Sub
'********************************************************************
Private Function WerktagsVon09Bis1800(dDateTime As Date, dTimeOffset As Date, _
                                      bZeitGrenzeDurchOffset As Boolean, _
                                      b9UhrGrenze As Boolean, _
                                      dDiffDateTimeBis900 As Date, _
                                      dDateTime900 As Date, _
                                      dDiffDateTimeAb900 As Date, _
                                      b18UhrGrenze As Boolean, _
                                      dDateTime1800 As Date, _
                                      dDiffDateTimeBis1800 As Date, _
                                      dDateTime1801 As Date, _
                                      dDiffDateTimeAb1801 As Date) As Boolean
'***   True, wenn Datum/Zeit Werktags(Mo-Fr) 9:00 bis 18:00 ist
  
  Dim iWochentag As Integer
  Dim iStd As Integer, iMin As Integer, iSec As Integer
  Dim iOffsetStd As Integer, iOffsetMin As Integer
  Dim dDateTime2 As Date
  Dim iWochentag2 As Integer
  Dim iStd2 As Integer, iMin2 As Integer, iSec2 As Integer
  Dim bWerktagsVon09Bis1800 As Boolean
  
  
 ->*** Löschsperre erstmal löschen
  bZeitGrenzeDurchOffset = False
  
 ->*** DateTime
  
  iWochentag = WeekDay(dDateTime)
  iStd = Hour(dDateTime)
  iMin = Minute(dDateTime)
  iSec = Second(dDateTime)
  iOffsetStd = Hour(dTimeOffset)
  iOffsetMin = Minute(dTimeOffset)
  
 ->Werktags9bis18Uhr ? für DateTime
  If IstFeiertag(dDateTime) Then
    WerktagsVon09Bis1800 = False
  ElseIf (iWochentag = vbSaturday) Or (iWochentag = vbSunday) Then
    WerktagsVon09Bis1800 = False
  ElseIf iStd >= 9 And iStd &lt;= 17 Then
    WerktagsVon09Bis1800 = True
  ElseIf iStd = 18 And iMin = 0 And iSec = 0 Then
    WerktagsVon09Bis1800 = True
  Else
    WerktagsVon09Bis1800 = False
  End If
  
 ->*** DateTime + Zeitoffset
  
 ->Zeitoffset auf DateTime addieren -> DateTime2
  dDateTime2 = DateAdd(h, iOffsetStd, dDateTime)->std
  dDateTime2 = DateAdd(n, iOffsetMin, dDateTime2)->min
  iWochentag2 = WeekDay(dDateTime2)
  iStd2 = Hour(dDateTime2)
  iMin2 = Minute(dDateTime2)
  iSec2 = Second(dDateTime2)

 ->Werktags9bis18Uhr ? für DateTime2
  If IstFeiertag(dDateTime2) Then
    bWerktagsVon09Bis1800 = False
  ElseIf (iWochentag2 = vbSaturday) Or (iWochentag2 = vbSunday) Then
    bWerktagsVon09Bis1800 = False
  ElseIf iStd2 >= 9 And iStd2 &lt;= 17 Then
    bWerktagsVon09Bis1800 = True
  ElseIf iStd2 = 18 And iMin2 = 0 And iSec2 = 0 Then
    bWerktagsVon09Bis1800 = True
  Else
    bWerktagsVon09Bis1800 = False
  End If

  b9UhrGrenze = False
  b18UhrGrenze = False
  
 ->Urteil für beide Datum ungleich ?
  If Not (bWerktagsVon09Bis1800 = WerktagsVon09Bis1800) Then
   ->nein -> nicht löschen
    bZeitGrenzeDurchOffset = True
        
   ->Grenze 9:00 bzw. 18:00
    If iStd &lt; 9 And iStd2 >= 9 Then b9UhrGrenze = True Else b18UhrGrenze = True
    
    If b9UhrGrenze Then
     ->datum 9 uhr erzeugen
      dDateTime900 = Format(dDateTime, dd.mm.yyyy)
      dDateTime900 = DateAdd(h, 9, dDateTime900)
     ->Differenzen für Offset berechnen
      dDiffDateTimeBis900 = dDateTime900 - dDateTime
      dDiffDateTimeAb900 = dDateTime2 - dDateTime900
    End If
    If b18UhrGrenze Then
     ->datum 18 uhr erzeugen
      dDateTime1800 = Format(dDateTime, dd.mm.yyyy)
      dDateTime1800 = DateAdd(h, 18, dDateTime1800)
     ->datum 18:01 uhr erzeugen
      dDateTime1801 = Format(dDateTime, dd.mm.yyyy)
      dDateTime1801 = DateAdd(h, 18, dDateTime1801)
      dDateTime1801 = DateAdd(n, 1, dDateTime1801)
     ->Differenzen für Offset berechnen
      dDiffDateTimeBis1800 = dDateTime1800 - dDateTime
      dDiffDateTimeAb1801 = dDateTime2 - dDateTime1801
    End If
    
  End If
End Function
'********************************************************************
Private Function IstFeiertag(dDateTime As Date) As Boolean
'***   True, wenn Datum/Zeit Feiertag ist

  Dim FeiertageDatum As Variant
  FeiertageDatum = Array(14.4.2006, 16.4.2006, 17.4.2006, _
                         1.5.2006, 25.5.2006, 4.6.2006, _
                         5.6.2006)
  
  Dim sDatum As String, x As Long
  
  sDatum = Format(dDateTime, d.m.yyyy)
  IstFeiertag = False
  For x = LBound(FeiertageDatum) To UBound(FeiertageDatum)
    If sDatum = FeiertageDatum(x) Then IstFeiertag = True: Exit For
  Next
End Function
Private Function TelefonNummernfilter(sTelNr As String) As Boolean
'***   True, wenn sTelNr mit einem TelNrFilter anfängt

  Dim TelNrFilter As Variant, x As Long
  TelNrFilter = Array(170, 171)

  TelefonNummernfilter = False
  If sTelNr =  Then Exit Function
  For x = LBound(TelNrFilter) To UBound(TelNrFilter)
    If TelNrFilter(x) = Left(sTelNr, Len(TelNrFilter(x))) Then
      TelefonNummernfilter = True: Exit For
    End If
  Next

End Function

tm · 14.06.2006

Hi Matjes,

zunächst mal DANKE !!! DANKE !!!
läuft wirklich soweit SUPER !!

noch eine Sache/Frage; eigentlich nur ein Schönheitsfehler !?
z. B. bei folg. Ausgangswert ...08:59 und Dauer 00:01 steht
bei Script 1: ..09:00 Dauer 00:00
bei Script 2: ..08:59 Dauer 00:01

wäre es ohne großen Aufwand möglich, das sozusagen bei diesen Grenzfällen wenn immer Rest 00:00 rauskommt,
die Zeile dann nicht in der entsprechenden Auswertung steht.
Im o. g. Beispiel, also die Auswertung bei Script 1.
(oder kann man das anders lösen; evtl. auch mit Schalter !?) ??
Das gleiche gilt natürlich, umgekehrt bei 17:xx, also wenn die Zeit genau 18:00 ergibt und die Restdauer auch hier 00:00 ist.

P.S.:
aber lies vorher mal meine PM

gruss
tm13

Matjes · 14.06.2006

Hallo tm,

jetzt ist wieder Halbzeit ;D

Jetzt mit einem 3. Schalter :

Offset 00:00 wird jetzt gelöscht. probiers mal aus.

Gruß Matjes

Code:

Option Explicit
Private Const cSPDATETIME = 2     'Spalte Datum/Zeit
Private Const cSPTELNR = 3       ->Spalte Telefonnummer
Private Const cSPTIMEOFFSET = 6   'Spalte Zeitoffset
Private Const cZUEBERCHRIFT = 1   'Zeile Überschrift

'Werden die Zeitgrenzen 9:00 bzw. 18:00 durch den Offset überschritten
'werden die Zeit(DATETIME) und der ZeitOffset angepasst, wenn
'der folgende Schalter auf True steht.
'bei False werden bleiben beide Werte unverändert
Private Const cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN = True
'dieser Schalter auf false unterdrückt die Änderung von Spalte B (DATETIME)
Private Const cSCHALTER_BEIZEITGRENZE_ZEITEN_SPALTE_B_MODIFIZIEREN = False
'dieser Schalter auf true löscht die Grenzsätze mit DATETMEDIFF =0
Private Const cSCHALTER_BEIZEITGRENZE_ZEITDIFFNULL_SATZLOESCHEN = True


'********************************************************************
Sub Excel_ZLoeNichtWerktags9bis18Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDateTime As Date, dTimeOffset As Date
  Dim bZeitGrenzeDurchOffset As Boolean
  Dim b9UhrGrenze As Boolean
  Dim dDiffDateTimeBis900 As Date
  Dim dDateTime900 As Date, dDiffDateTimeAb900 As Date
  Dim b18UhrGrenze As Boolean
  Dim dDateTime1800 As Date, dDiffDateTimeBis1800 As Date
  Dim dDateTime1801 As Date, dDiffDateTimeAb1801 As Date
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To cZUEBERCHRIFT + 1 Step -1
    sTelNr = ActiveSheet.Cells(lZeile, cSPTELNR).Value
    If TelefonNummernfilter(sTelNr) Then
     ->gefilterte Telnummern auf jeden Fall löschen
      ActiveSheet.Rows(lZeile).Delete
    Else
     ->Zeilen ohne Datum überspringen
      If IsDate(ActiveSheet.Cells(lZeile, cSPDATETIME).Value) Then
        dDateTime = ActiveSheet.Cells(lZeile, cSPDATETIME).Value
        dTimeOffset = ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value
        If Not WerktagsVon09Bis1800(dDateTime, dTimeOffset, _
                                    bZeitGrenzeDurchOffset, _
                                    b9UhrGrenze, _
                                    dDiffDateTimeBis900, _
                                    dDateTime900, dDiffDateTimeAb900, _
                                    b18UhrGrenze, _
                                    dDateTime1800, dDiffDateTimeBis1800, _
                                    dDateTime1801, dDiffDateTimeAb1801) Then
          If Not bZeitGrenzeDurchOffset Then
            ActiveSheet.Rows(lZeile).Delete
          End If
        End If
        If bZeitGrenzeDurchOffset Then
          If cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN Then
            If b9UhrGrenze Then
              If cSCHALTER_BEIZEITGRENZE_ZEITEN_SPALTE_B_MODIFIZIEREN Then
                ActiveSheet.Cells(lZeile, cSPDATETIME).Value = dDateTime900
              End If
              If Hour(dDiffDateTimeAb900) = 0 And Minute(dDiffDateTimeAb900) = 0 Then
                If cSCHALTER_BEIZEITGRENZE_ZEITDIFFNULL_SATZLOESCHEN Then
                  ActiveSheet.Rows(lZeile).Delete
                Else
                  ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
                End If
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeAb900
              End If
            End If
            If b18UhrGrenze Then
              If Hour(dDiffDateTimeBis1800) = 0 And Minute(dDiffDateTimeBis1800) = 0 Then
                If cSCHALTER_BEIZEITGRENZE_ZEITDIFFNULL_SATZLOESCHEN Then
                  ActiveSheet.Rows(lZeile).Delete
                Else
                  ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
                End If
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeBis1800
              End If
            End If
          End If
        End If
      End If
    End If
  Next
End Sub
'********************************************************************
Sub Excel_ZLoeWerktags9bis18Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDateTime As Date, dTimeOffset As Date
  Dim bZeitGrenzeDurchOffset As Boolean
  Dim b9UhrGrenze As Boolean
  Dim dDiffDateTimeBis900 As Date
  Dim dDateTime900 As Date, dDiffDateTimeAb900 As Date
  Dim b18UhrGrenze As Boolean
  Dim dDateTime1800 As Date, dDiffDateTimeBis1800 As Date
  Dim dDateTime1801 As Date, dDiffDateTimeAb1801 As Date
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To cZUEBERCHRIFT + 1 Step -1
    sTelNr = ActiveSheet.Cells(lZeile, cSPTELNR).Value
    If TelefonNummernfilter(sTelNr) Then
     ->gefilterte Telnummern auf jeden Fall löschen
      ActiveSheet.Rows(lZeile).Delete
    Else
     ->Zeilen ohne Datum überspringen
      If IsDate(ActiveSheet.Cells(lZeile, cSPDATETIME).Value) Then
        dDateTime = ActiveSheet.Cells(lZeile, cSPDATETIME).Value
        dTimeOffset = ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value
        If WerktagsVon09Bis1800(dDateTime, dTimeOffset, _
                                    bZeitGrenzeDurchOffset, _
                                    b9UhrGrenze, _
                                    dDiffDateTimeBis900, _
                                    dDateTime900, dDiffDateTimeAb900, _
                                    b18UhrGrenze, _
                                    dDateTime1800, dDiffDateTimeBis1800, _
                                    dDateTime1801, dDiffDateTimeAb1801) Then
          If Not bZeitGrenzeDurchOffset Then
            ActiveSheet.Rows(lZeile).Delete
          End If
        End If
        If bZeitGrenzeDurchOffset Then
          If cSCHALTER_BEIZEITGRENZE_ZEITEN_MODIFIZIEREN Then
            If b9UhrGrenze Then
              If Hour(dDiffDateTimeBis900) = 0 And Minute(dDiffDateTimeBis900) = 0 Then
                If cSCHALTER_BEIZEITGRENZE_ZEITDIFFNULL_SATZLOESCHEN Then
                  ActiveSheet.Rows(lZeile).Delete
                Else
                  ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
                End If
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeBis900
              End If
            End If
            If b18UhrGrenze Then
              If cSCHALTER_BEIZEITGRENZE_ZEITEN_SPALTE_B_MODIFIZIEREN Then
                ActiveSheet.Cells(lZeile, cSPDATETIME).Value = dDateTime1801
              End If
              If Hour(dDiffDateTimeAb1801) = 0 And Minute(dDiffDateTimeAb1801) = 0 Then
                If cSCHALTER_BEIZEITGRENZE_ZEITDIFFNULL_SATZLOESCHEN Then
                  ActiveSheet.Rows(lZeile).Delete
                Else
                  ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = 
                End If
              Else
                ActiveSheet.Cells(lZeile, cSPTIMEOFFSET).Value = dDiffDateTimeAb1801
              End If
            End If
          End If
        End If
      End If
    End If
  Next
End Sub
'********************************************************************
Private Function WerktagsVon09Bis1800(dDateTime As Date, dTimeOffset As Date, _
                                      bZeitGrenzeDurchOffset As Boolean, _
                                      b9UhrGrenze As Boolean, _
                                      dDiffDateTimeBis900 As Date, _
                                      dDateTime900 As Date, _
                                      dDiffDateTimeAb900 As Date, _
                                      b18UhrGrenze As Boolean, _
                                      dDateTime1800 As Date, _
                                      dDiffDateTimeBis1800 As Date, _
                                      dDateTime1801 As Date, _
                                      dDiffDateTimeAb1801 As Date) As Boolean
'***   True, wenn Datum/Zeit Werktags(Mo-Fr) 9:00 bis 18:00 ist
  
  Dim iWochentag As Integer
  Dim iStd As Integer, iMin As Integer, iSec As Integer
  Dim iOffsetStd As Integer, iOffsetMin As Integer
  Dim dDateTime2 As Date
  Dim iWochentag2 As Integer
  Dim iStd2 As Integer, iMin2 As Integer, iSec2 As Integer
  Dim bWerktagsVon09Bis1800 As Boolean
  
  
 ->*** Löschsperre erstmal löschen
  bZeitGrenzeDurchOffset = False
  
 ->*** DateTime
  
  iWochentag = WeekDay(dDateTime)
  iStd = Hour(dDateTime)
  iMin = Minute(dDateTime)
  iSec = Second(dDateTime)
  iOffsetStd = Hour(dTimeOffset)
  iOffsetMin = Minute(dTimeOffset)
  
 ->Werktags9bis18Uhr ? für DateTime
  If IstFeiertag(dDateTime) Then
    WerktagsVon09Bis1800 = False
  ElseIf (iWochentag = vbSaturday) Or (iWochentag = vbSunday) Then
    WerktagsVon09Bis1800 = False
  ElseIf iStd >= 9 And iStd &lt;= 17 Then
    WerktagsVon09Bis1800 = True
  ElseIf iStd = 18 And iMin = 0 And iSec = 0 Then
    WerktagsVon09Bis1800 = True
  Else
    WerktagsVon09Bis1800 = False
  End If
  
 ->*** DateTime + Zeitoffset
  
 ->Zeitoffset auf DateTime addieren -> DateTime2
  dDateTime2 = DateAdd(h, iOffsetStd, dDateTime)->std
  dDateTime2 = DateAdd(n, iOffsetMin, dDateTime2)->min
  iWochentag2 = WeekDay(dDateTime2)
  iStd2 = Hour(dDateTime2)
  iMin2 = Minute(dDateTime2)
  iSec2 = Second(dDateTime2)

 ->Werktags9bis18Uhr ? für DateTime2
  If IstFeiertag(dDateTime2) Then
    bWerktagsVon09Bis1800 = False
  ElseIf (iWochentag2 = vbSaturday) Or (iWochentag2 = vbSunday) Then
    bWerktagsVon09Bis1800 = False
  ElseIf iStd2 >= 9 And iStd2 &lt;= 17 Then
    bWerktagsVon09Bis1800 = True
  ElseIf iStd2 = 18 And iMin2 = 0 And iSec2 = 0 Then
    bWerktagsVon09Bis1800 = True
  Else
    bWerktagsVon09Bis1800 = False
  End If

  b9UhrGrenze = False
  b18UhrGrenze = False
  
 ->Urteil für beide Datum ungleich ?
  If Not (bWerktagsVon09Bis1800 = WerktagsVon09Bis1800) Then
   ->nein -> nicht löschen
    bZeitGrenzeDurchOffset = True
        
   ->Grenze 9:00 bzw. 18:00
    If iStd &lt; 9 And iStd2 >= 9 Then b9UhrGrenze = True Else b18UhrGrenze = True
    
    If b9UhrGrenze Then
     ->datum 9 uhr erzeugen
      dDateTime900 = Format(dDateTime, dd.mm.yyyy)
      dDateTime900 = DateAdd(h, 9, dDateTime900)
     ->Differenzen für Offset berechnen
      dDiffDateTimeBis900 = dDateTime900 - dDateTime
      dDiffDateTimeAb900 = dDateTime2 - dDateTime900
    End If
    If b18UhrGrenze Then
     ->datum 18 uhr erzeugen
      dDateTime1800 = Format(dDateTime, dd.mm.yyyy)
      dDateTime1800 = DateAdd(h, 18, dDateTime1800)
     ->datum 18:01 uhr erzeugen
      dDateTime1801 = Format(dDateTime, dd.mm.yyyy)
      dDateTime1801 = DateAdd(h, 18, dDateTime1801)
      dDateTime1801 = DateAdd(n, 1, dDateTime1801)
     ->Differenzen für Offset berechnen
      dDiffDateTimeBis1800 = dDateTime1800 - dDateTime
      dDiffDateTimeAb1801 = dDateTime2 - dDateTime1801
    End If
    
  End If
End Function
'********************************************************************
Private Function IstFeiertag(dDateTime As Date) As Boolean
'***   True, wenn Datum/Zeit Feiertag ist

  Dim FeiertageDatum As Variant
  FeiertageDatum = Array(14.4.2006, 16.4.2006, 17.4.2006, _
                         1.5.2006, 25.5.2006, 4.6.2006, _
                         5.6.2006)
  
  Dim sDatum As String, x As Long
  
  sDatum = Format(dDateTime, d.m.yyyy)
  IstFeiertag = False
  For x = LBound(FeiertageDatum) To UBound(FeiertageDatum)
    If sDatum = FeiertageDatum(x) Then IstFeiertag = True: Exit For
  Next
End Function
Private Function TelefonNummernfilter(sTelNr As String) As Boolean
'***   True, wenn sTelNr mit einem TelNrFilter anfängt

  Dim TelNrFilter As Variant, x As Long
  TelNrFilter = Array(170, 171)

  TelefonNummernfilter = False
  If sTelNr =  Then Exit Function
  For x = LBound(TelNrFilter) To UBound(TelNrFilter)
    If TelNrFilter(x) = Left(sTelNr, Len(TelNrFilter(x))) Then
      TelefonNummernfilter = True: Exit For
    End If
  Next

End Function

tm · 15.06.2006

Hi Matjes,

hab noch 2 Fehler entdeckt (weis jetzt aber nicht, ob die vorher nicht auch schon da war; ist mir vorher evtl. gar nicht aufgefallen !?)

a)
wenn z. b. ausgangswert ... 17:41 Dauer 00:21, dann erscheint im
script 1 ... 17:41 Dauer 00:19 (wäre also richtig) und im
script 2 ... 18:01 Dauer 00:01 (falsch, müsste 18:00 00:02 sein)
(wenn 17:41 und Dauer 00:20 wäre, dann ist script 1 wie oben und bei script 2 steht nix !
bei der 09:00 grenze scheint alles in ordnung zu sein !)

b)
wenn z. b. folg. ausganswerte da sind, also genau die grenze getroffen wird:
09.00 Dauer 00:01
18.00 Dauer 00:01
dann stehen beide werte in script 2 (18.00 bis 09.00; script 1 wäre 09.00 - 18.00)
18.00 mit 00:01 wäre ja richtig,
aber 09.00 mit 00:01 müsste aber eigentlich im script 1 stehen, da ja eigentlich 09.00 der beginn bei script 1 ist)

vielleicht müssten die grenzen anders definiert werden !??
09.00 bis 17.59.59 und 18.00 bis 08.59.59 ??
die ausgangswerte selbst haben zwar alle Sekunden, die aber immer null haben.

Matjes · 15.06.2006

Hallo tm,

vielleicht müssten die grenzen anders definiert werden !??
09.00 bis 17.59.59 und 18.00 bis 08.59.59 ??
die ausgangswerte selbst haben zwar alle Sekunden, die aber immer null haben.

Das halt ich für einen Vorschlag.

Heute abend werd ich eine 2. Version mit diesem Ansatz erstellen.

Gruß Matjes

tm · 15.06.2006

hi matjes,

hab jetzt mal selbst versucht, aus deinen scripten, ein´s zu basteln,
was ich noch benötigen würde.
es sollen nur zeilen stehen bleiben die dem telefonfilter entsprechen.

wenn ich die Funktion ..Werktag.. drin lasse (zumindest den oberen teil)
und auch diese if abfrage mit dem ..werktag.. so stehen lassen würde, dann gehts sogar.
aber sauber ist es nicht.

und so läuft es aber nicht.
siehe hier:

'********************************************************************
Sub ZeileNichtLoeschen()

'
' Zeile_NichtLoeschenWennTelefonnummernfilter Makro
'

'
Const c_SP_B = 2
Const c_SP_C = 3
Const c_ZUEBERCHRIFT = 1->Zeile Überschrift
Dim lLetzteZeile As Long, lZeile As Long, dDateTime As Date, sTelNr As String

lLetzteZeile = ActiveSheet.UsedRange.Row + _
ActiveSheet.UsedRange.Rows.Count - 1
For lZeile = lLetzteZeile To c_ZUEBERCHRIFT + 1 Step -1
->Zeilen ohne Datum überspringen
If IsDate(ActiveSheet.Cells(lZeile, c_SP_B).Value) Then
dDateTime = ActiveSheet.Cells(lZeile, c_SP_B).Value
If TelefonNummernfilter(sTelNr) Then
sTelNr = ActiveSheet.Cells(lZeile, c_SP_C).Value
If Not TelefonNummernfilter(sTelNr) Then
ActiveSheet.Rows(lZeile).Delete
End If
End If
End If
Next
End Sub
'********************************************************************
Private Function TelefonNummernfilter(sTelNr As String) As Boolean
'*** True, wenn sTelNr mit einem TelNrFilter anfängt

Dim TelNrFilter As Variant, x As Long
TelNrFilter = Array(0170, 0171)

TelefonNummernfilter = False
If sTelNr = Then Exit Function
For x = LBound(TelNrFilter) To UBound(TelNrFilter)
If TelNrFilter(x) = Left(sTelNr, Len(TelNrFilter(x))) Then
TelefonNummernfilter = True: Exit For
End If
Next

End Function

Matjes · 16.06.2006

2 Zeilen noch zuviel aber sonst schon brauchbar

Gruß Matjes

Code:

Sub ZeileLoeschen_WennNichtImTelefonnummernfiler()

  Const c_SP_B = 2
  Const c_SP_C = 3
  Const c_ZUEBERCHRIFT = 1->Zeile Überschrift
  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  
  lLetzteZeile = ActiveSheet.UsedRange.Row + _
                 ActiveSheet.UsedRange.Rows.Count - 1
  For lZeile = lLetzteZeile To c_ZUEBERCHRIFT + 1 Step -1
   ->Zeilen ohne Datum überspringen
    If IsDate(ActiveSheet.Cells(lZeile, c_SP_B).Value) Then
      sTelNr = ActiveSheet.Cells(lZeile, c_SP_C).Value
      If Not TelefonNummernfilter(sTelNr) Then
       ->nicht im Telefonnummernfilter -> dann löschen
        ActiveSheet.Rows(lZeile).Delete
      End If
    End If
  Next
End Sub

[br]Erstellt am: 15.06.06 um 17:27:14

du hast Post

tm · 16.06.2006

So, nun geht alles !!

Es läuft alles 1a !!!

Dem Macro Gott :T Matjes sei Dank !!!!!

Gruss
tm

Matjes · 16.06.2006

Dann den Makro nochmal zum mitlesen

Gruß Matjes

Code:

Option Explicit
Private Const cSPDATUMZEIT = 2       ->Spalte Datum/Zeit
Private Const cSPTELNR = 3           ->Spalte Telefonnummer
Private Const cSPZEITDAUER_HHMM = 6   'Spalte Zeitoffset
Private Const cZUEBERSCHRIFT = 1     ->Zeile Überschrift

'dieser Schalter auf false unterdrückt die Änderung von DatumZeit
Private Const cSCHALTER_ZEITGRENZE_DATUMZEIT_MOD = False


'********************************************************************
Sub Excel_ZLoeNichtWerktags0900bis1759Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDatumZeit As Date, dZeitdauer_hhmm As Date
  Dim bZeitGrenze As Boolean
  Dim b0900Grenze As Boolean, dZeitpunkt0900 As Date
  Dim dZeitdauerBis0859 As Date, dZeitdauerAb0900 As Date
  Dim b1800Grenze As Boolean, dZeitpunkt1800 As Date
  Dim dZeitdauerBis1759 As Date, dZeitdauerAb1800 As Date
  
  With ActiveSheet
  
    With .UsedRange: lLetzteZeile = .Row + .Rows.Count - 1: End With
    For lZeile = lLetzteZeile To cZUEBERSCHRIFT + 1 Step -1
      sTelNr = .Cells(lZeile, cSPTELNR).Value
      If TelefonNummernfilter(sTelNr) Then
       ->gefilterte Telnummern auf jeden Fall löschen
        .Rows(lZeile).Delete
      Else
       ->Zeilen ohne Datum überspringen
        If IsDate(.Cells(lZeile, cSPDATUMZEIT).Value) Then
          dDatumZeit = .Cells(lZeile, cSPDATUMZEIT).Value
          dZeitdauer_hhmm = .Cells(lZeile, cSPZEITDAUER_HHMM).Value
          If Not WerktagsVon0900Bis1759(dDatumZeit, dZeitdauer_hhmm, _
                                      bZeitGrenze, _
                                      b0900Grenze, dZeitpunkt0900, _
                                      dZeitdauerBis0859, dZeitdauerAb0900, _
                                      b1800Grenze, dZeitpunkt1800, _
                                      dZeitdauerBis1759, dZeitdauerAb1800) Then
            If Not bZeitGrenze Then .Rows(lZeile).Delete
          End If
          If bZeitGrenze Then
            If b0900Grenze Then
              If cSCHALTER_ZEITGRENZE_DATUMZEIT_MOD Then
                .Cells(lZeile, cSPDATUMZEIT).Value = dZeitpunkt0900
              End If
              If Hour(dZeitdauerAb0900) = 0 And Minute(dZeitdauerAb0900) = 0 Then
                .Rows(lZeile).Delete
              Else
                .Cells(lZeile, cSPZEITDAUER_HHMM).Value = dZeitdauerAb0900
              End If
            ElseIf b1800Grenze Then
              If Hour(dZeitdauerBis1759) = 0 And Minute(dZeitdauerBis1759) = 0 Then
                .Rows(lZeile).Delete
              Else
                .Cells(lZeile, cSPZEITDAUER_HHMM).Value = dZeitdauerBis1759
              End If
            End If
          End If
        End If
      End If
    Next
  End With
End Sub
'********************************************************************
Sub Excel_ZLoeWerktags0900bis1759Uhr()

  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  Dim dDatumZeit As Date, dZeitdauer_hhmm As Date
  Dim bZeitGrenze As Boolean
  Dim b0900Grenze As Boolean, dZeitpunkt0900 As Date
  Dim dZeitdauerBis0859 As Date, dZeitdauerAb0900 As Date
  Dim b1800Grenze As Boolean, dZeitpunkt1800 As Date
  Dim dZeitdauerBis1759 As Date, dZeitdauerAb1800 As Date
  
  With ActiveSheet
  
    With .UsedRange: lLetzteZeile = .Row + .Rows.Count - 1: End With
    For lZeile = lLetzteZeile To cZUEBERSCHRIFT + 1 Step -1
      sTelNr = .Cells(lZeile, cSPTELNR).Value
      If TelefonNummernfilter(sTelNr) Then
       ->gefilterte Telnummern auf jeden Fall löschen
        .Rows(lZeile).Delete
      Else
       ->Zeilen ohne Datum überspringen
        If IsDate(.Cells(lZeile, cSPDATUMZEIT).Value) Then
          dDatumZeit = .Cells(lZeile, cSPDATUMZEIT).Value
          dZeitdauer_hhmm = .Cells(lZeile, cSPZEITDAUER_HHMM).Value
          If WerktagsVon0900Bis1759(dDatumZeit, dZeitdauer_hhmm, _
                                      bZeitGrenze, _
                                      b0900Grenze, dZeitpunkt0900, _
                                      dZeitdauerBis0859, dZeitdauerAb0900, _
                                      b1800Grenze, dZeitpunkt1800, _
                                      dZeitdauerBis1759, dZeitdauerAb1800) Then
            If Not bZeitGrenze Then .Rows(lZeile).Delete
          End If
          If bZeitGrenze Then
            If b0900Grenze Then
              If Hour(dZeitdauerBis0859) = 0 And Minute(dZeitdauerBis0859) = 0 Then
                .Rows(lZeile).Delete
              Else
                .Cells(lZeile, cSPZEITDAUER_HHMM).Value = dZeitdauerBis0859
              End If
            ElseIf b1800Grenze Then
              If cSCHALTER_ZEITGRENZE_DATUMZEIT_MOD Then
                .Cells(lZeile, cSPDATUMZEIT).Value = dZeitpunkt1800
              End If
              If Hour(dZeitdauerAb1800) = 0 And Minute(dZeitdauerAb1800) = 0 Then
                .Rows(lZeile).Delete
              Else
                .Cells(lZeile, cSPZEITDAUER_HHMM).Value = dZeitdauerAb1800
              End If
            End If
          End If
        End If
      End If
    Next
  End With
End Sub
'********************************************************************
Private Function WerktagsVon0900Bis1759( _
                    dDatumZeit As Date, dZeitdauer_hhmm As Date, _
                    bZeitGrenze As Boolean, _
                    b0900Grenze As Boolean, dZeitpunkt0900 As Date, _
                    dZeitdauerBis0859 As Date, dZeitdauerAb0900 As Date, _
                    b1800Grenze As Boolean, dZeitpunkt1800 As Date, _
                    dZeitdauerBis1759 As Date, dZeitdauerAb1800 As Date) As Boolean
'***   True, wenn Datum/Zeit Werktags(Mo-Fr) 9:00 bis 17:59 ist
  
  Dim dDatumZeitPlusZeitdauer As Date, bWerktagsVon0900Bis1759 As Boolean
  
 ->*** Kennzeichen Überschreitung der Zeitgrenze erstmal löschen
  bZeitGrenze = False
  
 ->*** Datum/Zeit
  
 ->Werktags0900bis1759Uhr ? für DatumZeit
  WerktagsVon0900Bis1759 = True
  If Not IstFeiertag(dDatumZeit) Then
    If Not ((WeekDay(dDatumZeit) = vbSaturday) Or (WeekDay(dDatumZeit) = vbSunday)) Then
      If Hour(dDatumZeit) &lt; 9 Or Hour(dDatumZeit) > 17 Then
        WerktagsVon0900Bis1759 = False->außerhalb 9:00-17:59
      End If
    Else
      WerktagsVon0900Bis1759 = False->Samstag oder Sonntag
    End If
  Else
    WerktagsVon0900Bis1759 = False->Feiertag
  End If
  
 ->*** Datum/Zeit + Zeitdauer -1min
  
 ->dzeitdauer_hhmm auf DatumZeit addieren -> DatumZeitPlusZeitdauer
 ->(für Zeitrechnung 1min vom der Zeitdauer abziehen)
  dDatumZeitPlusZeitdauer = DateAdd(h, Hour(dZeitdauer_hhmm), dDatumZeit)               ->std
  dDatumZeitPlusZeitdauer = DateAdd(n, Minute(dZeitdauer_hhmm), dDatumZeitPlusZeitdauer)->min
  dDatumZeitPlusZeitdauer = DateAdd(n, -1, dDatumZeitPlusZeitdauer)                     ->-1 min

 ->Werktags9bis18Uhr ? für DateTime2
  bWerktagsVon0900Bis1759 = True
  If Not IstFeiertag(dDatumZeitPlusZeitdauer) Then
    If Not ((WeekDay(dDatumZeitPlusZeitdauer) = vbSaturday) Or _
            (WeekDay(dDatumZeitPlusZeitdauer) = vbSunday)) Then
      If Hour(dDatumZeitPlusZeitdauer) &lt; 9 Or Hour(dDatumZeitPlusZeitdauer) > 17 Then
        bWerktagsVon0900Bis1759 = False->außerhalb 9:00-17:59
      End If
    Else
      bWerktagsVon0900Bis1759 = False->Samstag oder Sonntag
    End If
  Else
    bWerktagsVon0900Bis1759 = False->Feiertag
  End If


  b0900Grenze = False
  b1800Grenze = False
  
 ->Urteil für beide Zeitpunkte ungleich ?
  If Not (bWerktagsVon0900Bis1759 = WerktagsVon0900Bis1759) Then
   ->nein -> nicht löschen
    bZeitGrenze = True
        
   ->Grenze 9:00 bzw. 18:00
    If Hour(dDatumZeit) &lt; 9 And Hour(dDatumZeitPlusZeitdauer) >= 9 Then
      b0900Grenze = True
    Else
      b1800Grenze = True
    End If
    
    If b0900Grenze Then
     ->datum 9 uhr erzeugen
      dZeitpunkt0900 = Format(dDatumZeit, dd.mm.yyyy)
      dZeitpunkt0900 = DateAdd(h, 9, dZeitpunkt0900)
     ->Differenzen für Zeitdauer berechnen
      dZeitdauerBis0859 = dZeitpunkt0900 - dDatumZeit
      dZeitdauerAb0900 = dDatumZeitPlusZeitdauer - dZeitpunkt0900
      dZeitdauerAb0900 = DateAdd(n, 1, dZeitdauerAb0900)
    End If
    
    If b1800Grenze Then
     ->datum 18 uhr erzeugen
      dZeitpunkt1800 = Format(dDatumZeit, dd.mm.yyyy)
      dZeitpunkt1800 = DateAdd(h, 18, dZeitpunkt1800)
     ->Differenzen für Zeitdauer berechnen
      dZeitdauerBis1759 = dZeitpunkt1800 - dDatumZeit
      dZeitdauerAb1800 = dDatumZeitPlusZeitdauer - dZeitpunkt1800
      dZeitdauerAb1800 = DateAdd(n, 1, dZeitdauerAb1800)
    End If
    
  End If
End Function
'********************************************************************
Private Function IstFeiertag(dDateTime As Date) As Boolean
'***   True, wenn Datum/Zeit Feiertag ist

  Dim FeiertageDatum As Variant
  FeiertageDatum = Array(14.4.2006, 16.4.2006, 17.4.2006, _
                         1.5.2006, 25.5.2006, 4.6.2006, _
                         5.6.2006)
  
  Dim sDatum As String, x As Long
  
  sDatum = Format(dDateTime, d.m.yyyy)
  IstFeiertag = False
  For x = LBound(FeiertageDatum) To UBound(FeiertageDatum)
    If sDatum = FeiertageDatum(x) Then IstFeiertag = True: Exit For
  Next
End Function
Private Function TelefonNummernfilter(sTelNr As String) As Boolean
'***   True, wenn sTelNr mit einem TelNrFilter anfängt

  Dim TelNrFilter As Variant, x As Long
  TelNrFilter = Array(170, 171)

  TelefonNummernfilter = False
  If sTelNr =  Then Exit Function
  For x = LBound(TelNrFilter) To UBound(TelNrFilter)
    If TelNrFilter(x) = Left(sTelNr, Len(TelNrFilter(x))) Then
      TelefonNummernfilter = True: Exit For
    End If
  Next

End Function
'********************************************************************
Sub ZeileLoeschen_WennNichtImTelefonnummernfiler()
'*** alle Zeilen löschen in denen eine Telefonnummer steht,
'*** die nicht vom Telefonnummernfilter erfasst wird
  Dim lLetzteZeile As Long, lZeile As Long, sTelNr As String
  
  With ActiveSheet
    With .UsedRange: lLetzteZeile = .Row + .Rows.Count - 1: End With
    For lZeile = lLetzteZeile To cZUEBERSCHRIFT + 1 Step -1
     ->Zeilen ohne Datum überspringen
      If IsDate(.Cells(lZeile, cSPDATUMZEIT).Value) Then
       ->nicht im Telefonnummernfilter -> dann löschen
        sTelNr = .Cells(lZeile, cSPTELNR).Value
        If Not TelefonNummernfilter(sTelNr) Then .Rows(lZeile).Delete
      End If
    Next
  End With
End Sub

Hilfe bei Excel Macro

tm

Matjes

tm

Matjes

tm

Matjes

tm

Matjes

tm

Matjes

Matjes

tm

Matjes

tm

Matjes

tm

Matjes

tm

Matjes

Hilfe bei Excel Macro

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums