Osaisiko joku auttaa?
Lähtöaineisto on yli 10 000 havainnon lista päivystysvuoroja tekijöineen muodossa:
Henkilö. Alkupäivä. Loppupäivä. Kesto
eli esim: matti. 3.1.2017. 6.1.2017. 4
maija 9.1.2017. 10.1.2017. 2
Samalla henkilöllä on listalla useampia rivejä, jokaisella eri määrä ja vuorot ovat erimittaisia ja menevät henkilöiden välillä osin pällekkäin. Henkilöitä listassa on reilu 400.
Miten saisin tuon sellaiseen muotoon,että yhtenä sarakkeena on aika juoksevana päivämääränä koko vuosi 1.1._31.12, siis yksi rivi/päivä. Ja ihmiset olisivat jokainen oma sarakkeensa, jossa olisi arvo 1 niiden päivien kohdalla,jolloin on päivystänyt, ja muiden päivien kohdalla arvo 0. Eli:
Matti. Maija. Jne.
1.1.2017. 0. 0
2.1.2017. 0. 0
3.1.2017. 1. 0
4.1.2017. 1. 0
5.1.2017. 1. 0
6.1.2017. 1. 0
7.1.2017. 0. 0
8.1.2017. 0. 0
9.1.2017. 0. 1
10.1.2017. 0. 1
11.1.2017. 0. 0
jne.
Jollain kaavalla varmasti menee, mutta millä ???
Aineisto aikasarjamuotoon?
1
157
Vastaukset
- Kundepuu
moduuliin...
muuta taulukon nimet sopiviksi
Option Explicit
Dim solu As Range
Dim Vika As Double
Dim i As Long
Dim j As Long
Dim EiTupla As New Collection
Dim Löydetty As Range
Sub teetaulukko()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Huuhaa").Delete
PoistaTuplat
Sheets.Add.Name = "Huuhaa"
Cells(1, 1) = "PVM"
Range("A2").FormulaR1C1 = "1/1/2017"
Range("A2").AutoFill Destination:=Range("A2:A366"), Type:=xlFillDefault
Range("A2:A366").NumberFormat = "d/m"
For i = 1 To EiTupla.Count
Worksheets("Huuhaa").Cells(1, i 1) = EiTupla(i)
EtsiJaSiirrä2 EiTupla(i), i
Next
Worksheets("Huuhaa").Range("B2").Resize(365, EiTupla.Count 1).SpecialCells(xlCellTypeBlanks) = 0
Application.DisplayAlerts = False
End Sub
Sub KirjoitaVuorot(Alku As Date, Loppu As Date, Siirtymä As Long)
Dim AlkuPäivänro As Variant
Dim LoppuPäivänro As Variant
If Loppu - Alku <= 0 Then
Exit Sub
End If
AlkuPäivänro = CDbl(Alku - DateValue("1.1") 1)
LoppuPäivänro = CDbl(Loppu - DateValue("1.1") 1)
For j = AlkuPäivänro To LoppuPäivänro
Worksheets("Huuhaa").Range("A1").Offset(j, Siirtymä) = 1
Next
End Sub
Function EtsiJaSiirrä2(Hakuehto As Variant, Sarake As Long) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
EkaOsoite = solu.Address
Do
KirjoitaVuorot solu.Offset(0, 1), solu.Offset(0, 2), Sarake
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address <> EkaOsoite
End If
End With
End Function
Sub PoistaTuplat()
On Error Resume Next
Vika = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
For Each solu In Range("A1:A" & Vika)
EiTupla.Add solu, CStr(solu)
Next
End Sub
Keep EXCELing
@Kunde
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Hengenvaaralliset kiihdytysajot päättyivät karmealla tavalla, kilpailija kuoli
Onnettomuudesta on aloitettu selvitys. Tapahtuma keskeytettiin onnettomuuteen. Tapahtumaa tutkitaan paikan päällä yhtei1976861- 1592026
- 1131678
- 511380
Suureksi onneksesi on myönnettävä
Että olen nyt sitten mennyt rakastumaan sinuun. Ei tässä mitään, olen kärsivällinen ❤️551228Möykkähulluus vaati kuolonuhrin
Nuori elämä menettiin täysin turhaan tällä järjettömyydellä! Toivottavasti näitä ei enää koskaan nähdä Kauhavalla! 😢501098Älä mies pidä mua pettäjänä
En petä ketään. Älä mies ajattele niin. Anteeksi että ihastuin suhun varattuna. Pettänyt en ole koskaan ketään vaikka hu1001064Reeniähororeeniä
Helvetillisen vaikeaa työskennellä hoitajana,kun ei kestä silmissään yhtään läskiä. Saati hoitaa sellaista. Mitä tehdä?6977Tarvitsemme lisää maahanmuuttoa.
Väestö eläköityy, eli tarvitsemme lisää tekeviä käsiä ja veronmaksajia. Ainut ratkaisu löytyy maahanmuutosta. Nimenomaan251944- 41919