Datum in Tab suchen, Werte vergleichen und Inhalte kopieren

[Micha63]

Hallo Forum,

möchte folgendes mittels VBA Code bewerkstelligen.
In der Tab Plan wird in Zelle B1 ein Datum eingegeben.
Das Datum wird in Tab Bsp. November in der N (hier N2) gefunden und Fundzelle wird ausgegeben:
VBA:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMon As Worksheet, lngC As Long
   If Not Target.Address(0, 0) = "B1" Then Exit Sub
   If Not IsDate(Target) Then MsgBox "Kein Datum - Abbruch": Exit Sub
   
   Set wsMon = Sheets(Format(Target, "mmmm"))   ' Tabellenblatt mit dem Monat
   lngC = Day(Target) + 4                       ' Spalte mit dem Tag

   MsgBox "Das eingegebene Datum steht in Blatt '" & wsMon.Name _
      & "' in Zelle " & Cells(2, lngC).Address
End Sub

Das klappt auch so.
Nun möchte ich weiter, dass verglichen wird was in Tab Plan in den Zellen D1, E1 und F1 steht und aus der Fundspalte (hier: N) bei Treffer die Werte aus Tab Monat: hier Spalte A, B, C, D und der Wert aus der Spalte des Tages in die Tab Plan übertragen werden in Spalte A-E.

Ist das möglich, oder denke ich da zu kompliziert und es gibt einen einfacheren Weg? 
Als Beispiel habe ich mal die Datei mit angefügt.
Danke für Eure Unterstützung, wenn es denn machbar ist.

Gruß Micha

  Vorplanung.xlsm (Größe: 23,85 KB / Downloads: 7)

[schauan]

Hallo Micha,

klingt erst mal gut. Du müsstest aber noch überlegen, mit was Du vergleichen willst und welche Zeilen / Zellen Du genau aus der Fundspalte und der Tabelle Monat Du brauchst und wo die Spalte des Tages genau ist.. Ich vermute mal, das ist auch N, wäre noch die Frage, auf welchem Blatt.

[Micha63]

Hallo schauan,

erstmal Danke für deine Antwort... 
Dachte schon das keiner etwas damit anfangen kann.

Gesucht werden soll dann natürlich immer in der Fundspalte des gefundenen Datum.

Die Werte aus der Fundspalte sollen dann verglichen werden mit den Werten aus der TabPlan, Zellen D1, E1 und F1.

Sobald der Vergleich passt aus der Spalte des Datum, dann die Werte aus den Zellen A, B, C und D und aus der Datumspalte kopieren und in TabPlan untereinander in Spalte A, B, C, D und E einfügen.

Sollte eigentlich in der Musterdatei die hier mit angefügt ist ersichtlich sein. Wenn nicht, dann kann ich ja noch eine einfache, übersichtlichere Datei hochladen.

Danke und Gruß

[Micha63]

Guten Morgen zusammen,

habe jetzt durch viel Probieren und Testen eine Möglichkeit gefunden das mir die Werte in die TAB Plan kopiert:
hier die Anweisung:

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim wsMon As Worksheet, lngC As Long, arD, arA, arB, arP, arZ, qq As Long
   Dim arE(), arF(), ee As Long, ff As Long, bolPr As Boolean
  
   If Not Target.Address(0, 0) = "B1" Then Exit Sub
   If Not IsDate(Target) Then MsgBox "Kein Datum - Abbruch": Exit Sub
  
   Set wsMon = Sheets(Format(Target, "mmmm"))   ' Tabellenblatt mit dem Monat
   lngC = Day(Target) + 4                       ' Spalte mit dem Tag
  
   arD = wsMon.Cells(8, lngC).Resize(447)        ' Werte Spalte des Tages
   arA = wsMon.Cells(8, 1).Resize(447)             ' Werte Spalte A
   arB = wsMon.Cells(8, 2).Resize(447)             ' Werte Spalte B
   arP = wsMon.Cells(8, 3).Resize(447)             ' Werte Spalte C
   arZ = wsMon.Cells(8, 4).Resize(447)             ' Spalte D
  
   ReDim arE(1 To UBound(arD), 8)
   ReDim arF(1 To UBound(arD), 8)
  
   For qq = 1 To UBound(arD)
      Select Case arD(qq, 1)
      Case "" ' leer
      Case Is = Worksheets("Plan").Range("D1").Value
         ' in D1 steht der Wert/ String
        
         ee = ee + 1
        
         arE(ee, 0) = arA(qq, 1)
         arE(ee, 1) = arB(qq, 1)
         arE(ee, 2) = arP(qq, 1)
         arE(ee, 3) = arD(qq, 1)
         arE(ee, 6) = arZ(qq, 1)
      End Select
      
   Next qq
   With Sheets("Plan")     ' Ausgabe in Blatt "Plan" - muss existieren
      .Range("A7:D150").ClearContents
      .Range("G7:G150").ClearContents
      .Cells(7, 1).Resize(ee, 7) = arE    ' primäre
      
      .Activate               ' falls Blatt Vorlage aktiv sein soll
   End With
End Sub

Macht das was er soll.
Jedoch habe ich noch das Problem, dass jetzt nur verglichen wird was in Zelle D1 und im TAB Monat in der Fundspalte steht. Also wenn in D1 zB ein "F" steht wird alles aus der Fundspalte kopiert wo auch ein F steht.
Brauche aber noch, dass mehrere Bedingungen kopiert werden.
Eventuell hat jemand jetzt eine Idee?

Gruß

[schauan]

Hallo Micha,

soll statt nach F noch nach was anderem gesucht werden oder soll in einer anderen Spalte noch nach F gesucht werden oder ...?

Mit Select Case bekommst Du nur einen Treffer verarbeitet.

Wenn Du mehrere If nacheinander nimmst, gehen mehrere.

Hier mal was zur Theorie:

Code:

Sub test()
a = 2
Select Case a
Case 2
MsgBox 1
Case 4 / 2
MsgBox 2
End Select
End Sub

Das wird Dir nur die 1 ausgeben.

Code:

Sub test()
a = 2
If a = 2 Then MsgBox 1
If a =  4 / 2 Then MsgBox 2
End Sub

Hier bekommst Du beide Meldungen

Select Case oder If kannst Du auch verwenden, wenn Du in mehreren Spalten oder verschiedenen Daten suchst, im Prinzip

Code:

Sub test()
a = 2
Select Case a
Case 2 / 2 And 4 / 2
MsgBox 1
Case 2 / 1 And 4 / 2
MsgBox 2
End Select
End Sub

[Micha63]

Hallo schauan,
gesucht wird immer nur in der einen Spalte mit dem eingegebenen Datum.
Das wonach gesucht werden soll ist etwas schwierig zu beschreiben. Versuche es mal:
Es geht eigentlich um eine Dienstplanung.
Eingabe Datum, Eingabe der Schicht, bsp. F für Früh
Es wird wie schon erwähnt das Datum gesucht, gefunden in einer Zelle bsp, N2 und alles was darunter kommt sind dann die eingetragenen Schichten.
So wie es jetzt ist wird nur nach F gesucht.
Da es aber noch andere Schichten während der Frühschicht gibt mit anderen Anfangs- und Endzeiten möchte ich bewirken, dass auch nach diesen Schichten gesucht wird.
bsp. Früh Anfang 6:00 Ende 14:00
F1 Anfang 6:30 Ende 14:30 usw.
Mit 'Case "F", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9", "F10", "F11", "F12", "F13", "S1", "S2" findet der Code auch all die geannten Schichten.
Das gilt nur für die Frühschicht und es gibt ja auch noch Spät und Nacht, und da weiß ich nicht wie ich das bewerkstelligen soll. Kann natürlcih alle Schichten in Case eintragen aber dann hat man ja nicht die differenzierung zw. Früh und Überlappung, Spät und Überlappung und Nacht und Überlappung.


Hatte so eine Idee:
Bsp.: Konstante oder Variable oder was geht: 
Case Früh
Früh = F, F1, F2, F3, S1, S2, Ü1, Ü2 usw
Case Spät
Spät = S, S1, S2, S3, S4, Ü2, Ü3, A3, A5 usw
Case Nacht
Nacht = N, N1, N2, N3, N4, N5, S4, S5, S6, Ü10 usw
und dann in der Abfrage:
Select Case arD(qq, 1)
      Case "" ' leer
      Case Is = Worksheets("Plan").Range("D1").Value ' und da steht dann zB Früh oder F, Spät oder S, Nacht oder N und bezieht sich dann auf Case Früh, Case Spät, Case Nacht??
Geht sowas?
Danke und Gruß Micha63

[schauan]

Hallo Micha,

dann würde ich lieber mit If arbeiten, z.B.

If arD(qq, 1) Like "F*" Then ...

und damit hättest Du alle Fälle, die mit F beginnen, abgedeckt.
Wenn Du D1 berücksichtigen willst eventuell so

If arD(qq, 1) Like Left(Worksheets("Plan").Range("D1").Value,1) & "*" Then ...

Damit ist es egal, ob dort F oder Früh steht.

Wenn Du aber bei Früh alles haben willst und ansonsten F1 oder F2, je nachdem, was dort steht, muss man es eventuell in 2 Stufen machen, wenn Früh alle F's betreffen soll.


Wenn da nicht nur F's berücksichtigt werden sollen sondern auch U10 oder was auch immer, kannst Du auch ein Array bilden und das in einer zusätzlichen "inneren" Schleife abarbeiten.
Im Prinzip so, und für die anderen Schichten analog:

Code:

Sub test()
Dim a$, arrSchichtF, iCnt%
a = "U10"
arrSchichtF = Array("F1", "F2", "U10")
For iCnt = 0 To UBound(arrSchichtF)
If a = arrSchichtF(iCnt) Then MsgBox "Das war " & iCnt
Next
End Sub

Man könnte da auch ein 2D-Array nehmen wo man noch die Schicht in der zusätzlichen Dimension verdrahtet und dann gezielt steuert, welche Schicht man durchlaufen will.

[Micha63]

Hallo schauan,
vielen Dank für deine Unterstützung 

das hier klingt und sieht für mich so aus als müsste es passen:

Wenn da nicht nur F's berücksichtigt werden sollen sondern auch U10 oder was auch immer, kannst Du auch ein Array bilden und das in einer zusätzlichen "inneren" Schleife abarbeiten.

Im Prinzip so, und für die anderen Schichten analog:

Code:

Sub test()
Dim a$, arrSchichtF, iCnt%
a = "U10"
arrSchichtF = Array("F1", "F2", "U10")
For iCnt = 0 To UBound(arrSchichtF)
If a = arrSchichtF(iCnt) Then MsgBox "Das war " & iCnt
Next
End Sub

Jetzt habe ich das Problem:
1. wie erweitere ich das für die anderen Schichten?
 
Dim a$, arrSchichtF, arrSchichtS, arrSchichtN, arrSchichtT, iCnt%
arrSchichtF = Array("F", "F1", "F2", "A1", "Ü1")
arrSchichtS = Array("S", "S1", "S2", "S3", "A8")
arrSchichtN = Array("N", "N1", "N2", "NL")
arrSchichtT = Array("T", "T1", "T2", "A2")
For iCnt = 0 To UBound(arrSchichtF)
For iCnt = 0 To UBound(arrSchichtS)
For iCnt = 0 To UBound(arrSchichtN)
For iCnt = 0 To UBound(arrSchichtT)
Next
End Sub

2. wie baue ich das dann in meinen bestehenden Code ein?

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim wsMon As Worksheet, lngC As Long, arD, arA, arB, arP, arZ, qq As Long
  Dim arE(), arF(), ee As Long, ff As Long, bolPr As Boolean
 
  If Not Target.Address(0, 0) = "B1" Then Exit Sub
  If Not IsDate(Target) Then MsgBox "Kein Datum - Abbruch": Exit Sub
 
  Set wsMon = Sheets(Format(Target, "mmmm"))   ' Tabellenblatt mit dem Monat
  lngC = Day(Target) + 4                       ' Spalte mit dem Tag
 
  arD = wsMon.Cells(8, lngC).Resize(447)        ' Werte Spalte des Tages
  arA = wsMon.Cells(8, 1).Resize(447)             ' Werte Spalte A
  arB = wsMon.Cells(8, 2).Resize(447)             ' Werte Spalte B
  arP = wsMon.Cells(8, 3).Resize(447)             ' Werte Spalte C
  arZ = wsMon.Cells(8, 4).Resize(447)             ' Spalte D
 
  ReDim arE(1 To UBound(arD), 8)
  ReDim arF(1 To UBound(arD), 8)
 
  For qq = 1 To UBound(arD)
     Select Case arD(qq, 1)
     Case "" ' leer
     Case Is = Worksheets("Plan").Range("D1").Value
        ' in D1 steht der Wert/ String
       
        ee = ee + 1
       
        arE(ee, 0) = arA(qq, 1)
        arE(ee, 1) = arB(qq, 1)
        arE(ee, 2) = arP(qq, 1)
        arE(ee, 3) = arD(qq, 1)
        arE(ee, 6) = arZ(qq, 1)
     End Select
     
  Next qq
  With Sheets("Plan")     ' Ausgabe in Blatt "Plan" - muss existieren
     .Range("A7:D150").ClearContents
     .Range("G7:G150").ClearContents
     .Cells(7, 1).Resize(ee, 7) = arE    ' primäre
     
     .Activate               ' falls Blatt Vorlage aktiv sein soll
  End With
End Sub

Ich hoffe du kannst mir dabei noch helfen?

Gruß Micha

[Micha63]

Hallo Zusammen,
möchte das Thema nochmal nach oben holen. 
Ich habe es bis heute leider noch nicht zu m laufen gebracht. 
Daher bleibt und ist meine Anfrage weiterhin offen und ich hoffe das sich vielleicht schauan diesem nochmal widmet...
 
Gruß Micha

[schauan]

Hallo Micha,

da hab ich bestimmt eine Benachrichtigung zu viel gelöscht oder keine bekommen

also so wird es eher nix.
For iCnt = 0 To UBound(arrSchichtF)
For iCnt = 0 To UBound(arrSchichtS)
For iCnt = 0 To UBound(arrSchichtN)
For iCnt = 0 To UBound(arrSchichtT)
Next

wenn, dann so
For iCnt = 0 To UBound(arrSchichtF)
Next
For iCnt = 0 To UBound(arrSchichtS)
Next
For iCnt = 0 To UBound(arrSchichtN)
Next
For iCnt = 0 To UBound(arrSchichtT)
Next

Je nachdem, ob ich Deinen Code richtig verstanden habe, könnte es so sein:

Code:

For qq = 1 To UBound(arD)
  For iCnt = 0 To UBound(arrSchichtF)
    If arrSchichtF(iCnt) = Worksheets("Plan").Range("D1").Value Then
        ee = ee + 1
        arE(ee, 0) = arA(qq, 1)
        arE(ee, 1) = arB(qq, 1)
        arE(ee, 2) = arP(qq, 1)
        arE(ee, 3) = arD(qq, 1)
        arE(ee, 6) = arZ(qq, 1)
        Exit For 
    End If
  Next iCnt
Next qq

Je nachdem, wie die Reihenfolge im arE sein soll, müsstest Du die anderen Schichten innerhalb der qq Schleife analog F der Reihe nach programmieren oder Du brauchst die qq Schleifen entsprechend oft