Keskustelu: Ohjelmointikysymykset: VBA: Excel ja päivämäärät

' Funktio hakemiston asettamiselle
Private Declare Function SetCurDir Lib "kernel32" _
    Alias "SetCurrentDirectoryA" _
    (ByVal lpPathName As String) As Long
Function WksExists(wksName As Variant) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Sheets(wksName).Name) > 0)
End Function
Function AvaaWorkbook(nimi As String) As Workbook
    On Error Resume Next
      Set AvaaWorkbook = Workbooks.Open(nimi, , True)
End Function
Sub käsi()
Dim tiednim
Dim tiimi As String
Dim wb As Workbook
Dim g As Integer
Dim kuukausi As String
Dim vuosi As String
Dim a_pvm As Date
Dim t_pvm As Date
Dim r_apvm As Date
Dim r_lpvm As Date
Dim t_apvm As Date
Dim t_lpvm As Date
Dim t_tpvm As Date

' kun kohdataan virhe jatketaan seuraavaan
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

mypath = Workbooks("Tiimivarmuus.xls").Worksheets("Data").Cells(9, 2).Value
' Asetetaan nykyinen hakemisto mypathiksi. Tämä helpottaa oikean hakemiston löytämistä.
SetCurDir (mypath)

' tiedostonimi josta toimitusvarmuudet poimitaan
tiednim = Application.GetOpenFilename(FileFilter:="Excel-tiedostot (*.xls), *.xls", Title:="Valitse tiedosto, josta poimitaan toimitusvarmuudet.")
    If tiednim = False Then
        ' Jos tiedostoa ei ole niin annetaan viesti
        MsgBox "Ei onnistu!"
        Exit Sub
    End If

'tiednimi = "C:\xxxx\xx\xxxxx.XLS"
'valinta = vbYesNo + vbQuestion
'jep = MsgBox("Haluatko jälkitoimitukset mukaan ?" & Chr(10), valinta)
jep = vbNo


Dim tiednimi As String
tiednimi = tiednim
Set wb = AvaaWorkbook(tiednimi)

r_apvm = Cells(4, 5).Value
r_lpvm = Cells(4, 7).Value


t_apvm = Workbooks("tiimivarmuus.xls").Worksheets("Data").Cells(2, 1).Value
' ensimäinen tilastoitu pvm
t_lpvm = Workbooks("tiimivarmuus.xls").Worksheets("Data").Cells(2, 2).Value
' viimeisin tilastoitu pvm
t_tpvm = Workbooks("tiimivarmuus.xls").Worksheets("Data").Cells(2, 4).Value
' nykyinen pvm

' tarkastellaan raportin päivämäärää ja ilmoitetaan jos se ei ole korrekti
' eli jos raportin loppupäivämäärä on suurempi kuin tämä päivä tai
' raportti on samalta päivämäärä alueelta kuin jo jokin olemassa oleva
' tilastoitu raportti.
If r_apvm >= t_tpvm Or r_lpvm >= t_tpvm Then
MsgBox "Tulostamasi raportti ei ole kurantti, koska se sisältää" & Chr(10) _
    & "aikavälin, joka ei ole korrekti!" & Chr(10) _
    & "Mitään muutoksia ei tehty! Yritä uudelleen..."
Exit Sub
End If



' jos raportin aloitus päivämäärä on tilastoinnin aikarajan sisällä tai
' jos raportin lopetus päivämäärä on tilastoinnin aikarajan sisällä niin
If t_apvm <= r_apvm And r_apvm <= t_lpvm Or t_apvm <= r_lpvm And r_lpvm <= t_lpvm Then
    MsgBox "Kyseiseltä aikaväliltä löytyy jo raportti!" & Chr(10) _
        & "Makron suoritus lopetetaan..." & Chr(10) _
        & "Mitään tietoja ei päivitetty." & Chr(10) _
        & "Tulosta raportti päivästä: " & t_lpvm + 1 & " eteenpäin."

    Exit Sub
Else
    If r_apvm = t_lpvm + 1 Then
        Workbooks("tiimivarmuus.xls").Worksheets("Data").Cells(2, 2).Value = r_lpvm
    Else
        MsgBox "tämä raportti jättää välistä päiviä et halua jatkaa =)" & Chr(10) _
        & "Aloita raportti päivästä: " & t_lpvm + 1 & " kiitos."
        Exit Sub
    End If

End If


l = Cells(Rows.Count, 4).End(xlUp).Row

For g = 1 To l
If l < g Then
Exit For
End If

' poistetaan pakkaukseen yms ylimääräiset rivit toimitusvarmuus tiedostosta
If Cells(g, 4).Value Like "*PAKKAUS*" Or Cells(g, 4).Value Like "*PALLET*" _
Or Cells(g, 4).Value Like "*DELIVERY*" Or Cells(g, 4).Value Like "*PACKING*" _
Or Cells(g, 4).Value Like "*LAVA*" Or Cells(g, 4).Value Like "*KAULUS*" _
Or Cells(g, 4).Value Like "*AMPSEAL*" Or Cells(g, 4).Value Like "*MUUTOS*" _
Or Cells(g, 4).Value Like "*TYÖ*" Or Cells(g, 4).Value Like "" _
Or Cells(g, 4).Value Like "*LISÄ*" Or Cells(g, 4).Value Like "*PAPERS*" _
Or Cells(g, 4).Value Like "*PAHVI*" Or Cells(g, 4).Value Like "*TÄYDENNYS*" _
Or Cells(g, 10).Value = 4292552277# _
Then
Rows(g & ":" & g).Delete Shift:=xlUp
g = g - 1
l = l - 1
    If g = 0 Then
    g = g + 1
    End If
End If

'Jos raportissa on tuplarivi merkintä eli g sarakkeessa on 2
' niin tuhotaan rivi tai kaksi riippuen jälkitoimitus asetuksesta
If Cells(g, 7).Value = 2 Then
    If jep = vbNo Then
        Rows(g & ":" & g).Delete Shift:=xlUp
        Rows(g & ":" & g).Delete Shift:=xlUp
        g = g - 2
        l = l - 2
    If g = 0 Then
    g = g + 1
    End If

    Else
        Rows(g & ":" & g).Delete Shift:=xlUp
        g = g - 1
        l = l - 1
    If g = 0 Then
    g = g + 1
    End If

    End If
End If

Next g

l = Cells(Rows.Count, 1).End(xlUp).Row

' kun ylimääräiset rivit poistettu niin käydään rivit läpi
' etsien sellaisten tuotteiden toimitusvarmuus, joilla ei ole
' tiimiä määriteltynä
For x = 1 To l
    If Cells(x, 8).Value Like "??.??.????" And Cells(x, 9).Value Like "??.??.????" Then
        Cells(x, 8).Activate
        rivi = ActiveCell.Row
        If Cells(rivi, 4).Value <> "" And Cells(rivi, 10).Value = "" Then
           ' MsgBox Cells(rivi, 4).Value & " - Tuote ilman tiimiä"
            a_pvm = Cells(rivi, 8).Value
            t_pvm = Cells(rivi, 9).Value
            team = Cells(rivi, 10).Value
            kuukausi = Right(Left(a_pvm, 5), 1)
            vuosi = Right(a_pvm, 4)

            ' jos aiottu toimituspäivämäärä on edessäpäin         toimituspäivämäärästä niin
            If a_pvm >= t_pvm Then
                'hyvä toimitus
                Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(2, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(2, kuukausi + 1).Value + 1
                Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(4, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(4, kuukausi + 1).Value + 1
            Else
                'jos aiottu toimituspäivämäärä on jo takana niin
                'paha toimitus
                Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(2, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(2, kuukausi + 1).Value + 1
                Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(3, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(3, kuukausi + 1).Value + 1
            End If

        End If

    End If
Next x

x = 0

Columns("J:J").Select
' Etsitään tiimilliset toimitukset raportista ja päivitetään tilastot
With Selection
    For x = 1 To 6
        tiimi = "0" & x
        Set c = .Find(tiimi)
        If Not c Is Nothing Then
            firstaddress = c.Address

            Do
                k = c.Address
                Range(k).Select
                rivi = ActiveCell.Row
                a_pvm = Cells(rivi, 8).Value
                t_pvm = Cells(rivi, 9).Value
                team = Cells(rivi, 10).Value
                kuukausi = Right(Left(a_pvm, 5), 2)
                vuosi = Right(a_pvm, 4)

                'If WksExists(vuosi) = True Then
                'Else
                '   Sheets.Add.Name = vuosi
                'End If

                If a_pvm >= t_pvm Then
                    'hyvä toimitus
                    Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 1, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 1, kuukausi + 1).Value + 1
                    Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 3, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 3, kuukausi + 1).Value + 1
                Else
                    'paha toimitus
                    Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 1, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 1, kuukausi + 1).Value + 1
                    Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 2, kuukausi + 1).Value = Workbooks("Tiimivarmuus.xls").Worksheets(vuosi).Cells(team * 7 + 2, kuukausi + 1).Value + 1
                End If

                Range(k).Value = ""
                Set c = .FindNext(c)

                If c Is Nothing Then
                    Exit Do
                End If

            Loop While Not c Is Nothing And firstaddress <> c.Address
        End If
    Next x
End With


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Workbooks("Tiimivarmuus.xls").Worksheets("Data").Activate
End Sub