Hozzászólás: Cella lekérdezés adott időszakra, eredmény összehasonlítása más értékkel

Sub test()
 
Dim MyRnd1 As Double
 
MyRnd1 = Int((999 - 1 + 1) * Rnd + 1)
MsgBox MyRnd1
MsgBox Replace(TimeValue(Now), ":", "")
 
End Sub
 
Sub Main()
 
'last update 2017.feb.28 - gege - initial version
 
' cső Norbi!
' a makrót többféleképpen is lehet futtatni, pl. altf + F8 --> kiválasztod a "main" nevűt --> run. Vagy beleteszed a kurzort ide a makró szövegébe és F5-öt nyomsz, vagy a play gombot.
' Javaslom, hogy az adatot amin futtatni akarod a makrót, másold egy új, külön xls-be (vagy másold ebbe az adatot, az is jó)
' a fájl kiterjesztésének xlsm-nek kell hogy legyen, ha makrót akarsz belerakni (vagy xls, de az csak 256 oszlopos, az nem lesz neked elég; szóval save as xlsm)
' első munkalapra menjen a shift plan
' másodikra a requestek
' a makró kidob egy új munkalapot a harmadik helyre, a lap nevének a vége egy generált érték (hogy ne egyezzen a neve esetleg korábbi futtatások kimenetével)
' nyugodtan nézd át a makrót, írogass át benne amit akarsz
' mindenképp az A1 cellában kezdődjön az adat (fejléc az első sor, aztán adat a másodiktól)
' a munkalapokon ne legyen más csak az adat és ne legyenek üres sorok, cellák ha lehet (legalábbis az első oszlopban semmiképp)
'jelenleg ha hétvégét is belevéve kért valaki szabadságot vagy táppénzt, azt nem egyezőnek veszi a makró, de odaíratom vele a kimenethez hogy az adott nap hétvége
' figyelem: a makró csak azt nézi, hogy az adott requestben kért dolgok benn vannak-e shift planben. Azt nem nézi, hogy van-e shift planben pl. betegség vagy vacation amire nem volt request!
'           ha azt is meg kéne nézni, azt majd megcsinálom, de egyelőre nem fog az agyam. valszeg azt más logikával kéne leprogramozni :D (most eszembe jutott hogy lehetne, leírom ide ha kell:
'                   egy tömbben eltárolni az összes request dátumát és a nevet akihez tartozik,
'                   majd a végén átnézni hogy van-e olyan név/dátum páros a shift planben ami sick vagy vacation, de nem volt rá request
' kérlek teszteld és ha van benne hiba, vagy más funkciót szeretnél belerakni akkor szólj. Holnap HO-ban vagyok, tudok majd vele foglalkozni kicsit.
 
Dim MyWb As Workbook
Dim MainWs As Worksheet 'shift plan
Dim ReqWs As Worksheet 'requests
Dim OutWs As Worksheet 'output goes here
Dim MyRnd As Double
Dim MyCell As Range 'variable for looping
Dim MyCell_2 As Range 'another variable for looping
Dim MyRow As Long
Dim MyCol As Long
 
'variables for shiftplan
Dim sTopLeft As Range 'first name's position on the top left of the shift plan (for defining the position of the requests table)
Dim sLr As Long 'last row with data
Dim sLc As Long 'last column with data
Dim sMainRange As Range 'all the data in the shiftplan
Dim sType As String
'variables for requests
Dim rTopLeft As Range 'first request's left cell (for defining the position of the requests table)
Dim rRange As Range 'all requests
Dim rName As String
Dim rTypeLong As String
Dim rType As String
Dim rDateStart As Long
Dim rDateEnd As Long
Dim rDateArray() As Long
Dim rLr As Long 'last row with data
Dim i As Long
Dim j As Long
 
Set MyWb = ThisWorkbook
Set MainWs = MyWb.Sheets(1) 'can be defined with name as well, for example Set MainWs = MyWb.Sheets("Shitftplan")
Set ReqWs = MyWb.Sheets(2) 'can be defined with name as well, for example Set ReqWs = MyWb.Sheets("Requests")
Set OutWs = MyWb.Sheets.Add(, ReqWs)
'MyRnd = Int((998 - 1 + 1) * Rnd + 1)
OutWs.Name = "Results_" & Replace(TimeValue(Now), ":", "")
 
'CURRENTLY THIS ONLY WORKS IF TOP LEFT IS A1, sorry...
Set sTopLeft = MainWs.Range("A1")
Set rTopLeft = ReqWs.Range("A1")
 
rLr = ReqWs.Cells(ReqWs.Rows.Count, rTopLeft.Column).End(xlUp).Row
sLr = MainWs.Cells(MainWs.Rows.Count, sTopLeft.Column).End(xlUp).Row
sLc = MainWs.Cells(sTopLeft.Row, MainWs.Columns.Count).End(xlToLeft).Column
Set sMainRange = MainWs.Range(sTopLeft, MainWs.Cells(sLr, sLc))
OutWs.Range("A1:F1").Value = Array("name", "date", "shitfplan_value", "request_value", "is_weekend", "comment")
 
'HORRIBLE HACK
Call Replace_dates(MainWs.Range(MainWs.Range("B1"), MainWs.Cells(1, sLc)))
 
'loop through requests and put values into variables
For Each MyCell In ReqWs.Range(rTopLeft.Offset(1, 0), ReqWs.Cells(rLr, rTopLeft.Column))
    rName = MyCell.Value
    rTypeLong = MyCell.Offset(0, 1).Value
        Select Case rTypeLong
'            Case "Morning": rType = "A"
'            Case "Afternoon": rType = "B"
'            Case "Night": rType = "C"
'            Case "Office": rType = "D"    ''' commented out because only sick / vacation requests are possible
            Case "Sick": rType = "X"
            Case "sick": rType = "X"
            Case "Holiday": rType = "V"
            Case "holiday": rType = "V"
            Case "Vacation": rType = "V"
            Case "vacation": rType = "V"
            Case Else: rType = "undefined"
        End Select
    rDateStart = CLng(DateValue(MyCell.Offset(0, 2).Value))
    rDateEnd = CLng(DateValue(MyCell.Offset(0, 3).Value))
    rDateArray = fillDates(rDateStart, rDateEnd)
   
    'let's find the name row from the request in the shiftplan
    MyRow = Application.WorksheetFunction.Match(rName, sMainRange.Columns(1), 0)
    'check each date and output if there is discrepancy
    For i = LBound(rDateArray) To UBound(rDateArray)
        MyCol = Application.WorksheetFunction.Match(rDateArray(i), sMainRange.Rows(1), 0)
        sType = MainWs.Cells(MyRow, MyCol).Value
        If sType <> rType Then
            With OutWs.Cells(j + 2, 1)
                .Value = rName
                .Offset(0, 1).Value = rDateArray(i)
                .Offset(0, 1).NumberFormat = "yyyy-mm-dd"
                .Offset(0, 2).Value = sType
                .Offset(0, 3).Value = rType
                If Application.Weekday(rDateArray(i), 2) >= 6 Then .Offset(0, 4).Value = "WEEKEND"
                .Offset(0, 5).Value = "Request was from " & CDate(rDateStart) & " to " & CDate(rDateEnd)
            End With
            j = j + 1
        End If
    Next i
Next
 
'some formatting, add more if you want
OutWs.Columns.AutoFit
 
 
 
'terv: ciklus menjen végig a requesteken
'       ciklus menjen végig a dátum intervallumokon, tegye be egy tömbbe (név, requesttype, dátumok)
'       kimenet is kerüljön be egy tömbbe
'       kimenetet tegye ki egy külön munkanapra (név, dátum, requesttype shitfplanről, ezzel nem egyező request érték)
End Sub
 
Sub Replace_dates(dRange As Range)
'horrible hack to make my match function work
'replace all dates in row 1 to integer numbers
Dim Rng As Range
 
For Each Rng In dRange
    Rng.Value = CLng(DateValue(Rng.Value))
Next
 
End Sub
 
Function fillDates(ByVal StartDate As Long, ByVal EndDate As Long) As Variant
'partially taken from http://stackoverflow.com/questions/29102506/get-all-dates-between-2-dates-in-vba
 
    Dim varDates()      As Long
    Dim lngDateCounter  As Long
 
    ReDim varDates(0 To EndDate - StartDate)
 
    For lngDateCounter = LBound(varDates) To UBound(varDates)
        varDates(lngDateCounter) = StartDate
        StartDate = StartDate + 1
    Next lngDateCounter
 
    fillDates = varDates
 
ClearMemory:
    If IsArray(varDates) Then Erase varDates
    lngDateCounter = Empty
 
End Function