jensen363 Seniormester
22. juli 2019 - 16:12 Der er 19 kommentarer og
2 løsninger

Gentag række x antal gangen i forhold tie start/slut dato

Jeg har en række med en Unique ID samt en række informationer I kolonner der tilknytter sig til denne ID.

I to af kolonnerne er angivet hhv startdato & sluddato, eksempel :

ID      StartDato    SlutDato
001  01-01-2019  03-01-2019

Jeg har behov for at få ovenstående gentaget I et nyt ark med en ekstra kolonne hvori informationen DiscountDato optræder

ID      StartDato    SlutDato      DiscountDato
001  01-01-2019  03-01-2019  01-01-2019
001  01-01-2019  03-01-2019  02-01-2019
001  01-01-2019  03-01-2019  03-01-2019

How to do ?
kim1a Ekspert
22. juli 2019 - 18:28 #1
Her er en vba i en meget basal form, du skal nok være lidt mere specifik end sheet1 og sheet2 etc. Derudover kan der være noget med overskrifter :-)

Sub discoutdato()

Dim intLastRowNo As Integer
Dim r As Integer
Dim p As Integer
Dim datStartDate As Date
Dim datEndDate As Date
Dim intNumberDiscountLines As Integer

intLastRowNo = Cells(Rows.Count, "A").End(xlUp).Row

For r = 2 To intLastRowNo

    datStartDate = Cells(r, 2).Value
    datEndDate = Cells(r, 3).Value
   
    intNumberDiscountLines = DateDiff("d", datStartDate, datEndDate) + 1

    For p = 1 To intNumberDiscountLines
        Sheets(1).Rows(r).Copy
        Sheets(2).Activate
        ActiveCell.PasteSpecial
        Cells(p, 4).Value = DateAdd("d", p - 1, datStartDate)
        Cells((Range("A" & Rows.Count).End(xlUp).Row) + 1, 1).Select
    Next

Next

End Sub
jensen363 Seniormester
23. juli 2019 - 09:20 #2
Perfekt, - takker
jensen363 Seniormester
23. juli 2019 - 11:55 #3
Og alligevel ikke :-(

Det genereres det korrekte antal rækker, men den ekstra kolonne med Discountdato opdateres ikke korrekt
jensen363 Seniormester
23. juli 2019 - 13:36 #4
Det ser også ud til at det genererer for mange rækker :-(
xl-Enthusiast Ekspert
23. juli 2019 - 14:58 #5
kim1a Ekspert
23. juli 2019 - 15:21 #6
Du må være lidt mere specifik - det virker for mig.

Hvad gør den præcis? For mange rækker, i hvilken dato, eller i alle datoerne?

Opdaterer ikke korrekt discount dato - hvad skriver den?
jensen363 Seniormester
23. juli 2019 - 15:27 #7
Kan jeg sende filen til dig ?
jensen363 Seniormester
24. juli 2019 - 08:36 #8
xl-Enthusiast :
Hvordan udvider jeg området med flere ID ... p.t. har jeg knap 5.000 forskellige ID'er
xl-Enthusiast Ekspert
24. juli 2019 - 08:56 #9
Hvis du mener tabellen i Sheet2 så trækker du bare ved den blå pil i nederste højre hjørne. Træk så langt ned som du har brug for. Hvis ikke formler automatisk følger med så vælg A31:D31 og træk i fyldhåndtaget i D31 så lang ned som nødvendigt.
jensen363 Seniormester
24. juli 2019 - 09:07 #10
xl-Enthusiast :
Nej, det er tabellen I Sheet1 der har 5.000 forskellige ID'er med hver sin hhv. start & slutdato :-)
xl-Enthusiast Ekspert
24. juli 2019 - 09:21 #11
Så har jeg ikke forstået opgaven.
Kan du ikke uploade en fil hvor du viser flere eksempler og manuelt indsætter de ønskede resultater?

Skrev du noget om flere rækker i dit oprindelige indlæg?
kim1a Ekspert
24. juli 2019 - 09:23 #12
Det var samme issue jeg havde med VBAen, det bør dog være løst nu med denne:

Sub discoutdato()

Dim intLastRowNo As Integer
Dim r As Integer
Dim p As Integer
Dim FromDate As Date
Dim ToDate As Date
Dim intNumberDiscountLines As Integer
Dim intFillOutRow As Integer

intLastRowNo = Cells(Rows.Count, "A").End(xlUp).Row

For r = 2 To intLastRowNo

    Sheets("DataSheet_1").Activate
    FromDate = Cells(r, 2).Value
    ToDate = Cells(r, 3).Value
   
    intNumberDiscountLines = DateDiff("d", FromDate, ToDate) + 1

    For p = 1 To intNumberDiscountLines
        Sheets("DataSheet_1").Rows(r).Copy
        Sheets("DataSheet_2").Activate
        ActiveCell.PasteSpecial
        intFillOutRow = Range("A" & Rows.Count).End(xlUp).Row
        Cells(intFillOutRow, 4).Value = DateAdd("d", p - 1, FromDate)
        Cells((Range("A" & Rows.Count).End(xlUp).Row) + 1, 1).Select
       
    Next

Next

End Sub
jensen363 Seniormester
24. juli 2019 - 09:33 #13
Det din array formel gør for ID no 1 skal jeg have gentaget for alle ID fra Sheet1 :

ID    FromDate    ToDate
1    05-07-2019    13-07-2019
2    30-07-2019    03-08-2019
3    10-08-2019    17-08-2019
4    03-06-2019    30-09-2019
5    18-05-2019    27-06-2019
...
jensen363 Seniormester
24. juli 2019 - 09:43 #14
Ok, jeg skrev ikke at det drejede sig om flere forskellige ID .... beklager
xl-Enthusiast Ekspert
24. juli 2019 - 09:53 #15
Det din array formel gør for ID no 1 skal jeg have gentaget for alle ID fra Sheet1

OK, men det har jeg ingen forslag til.
jensen363 Seniormester
24. juli 2019 - 10:01 #16
Øv .... vba versionen er heller ikke løsningen med så mange IDér

Den kørte ca 20 minutter, hvorefter den stoppede med Overflow error
kim1a Ekspert
24. juli 2019 - 10:12 #17
Kan det være fordi du har for mange linjer - husk på der kun er ca 1 mio rækker i Excel.
jensen363 Seniormester
24. juli 2019 - 10:18 #18
Den stopper efter at have behandlet ca. 1.000 rækker fra Sheet1, hvilket i Sheet2 giver ca. 35.000 rækker, så det er ikke det der er problemet :-(

Det er ikke det store problem, - jeg klipper bare filen i mindre bidder :-)
kim1a Ekspert
24. juli 2019 - 10:41 #19
Jeg er desværre ikke skarp nok til at forstå hvorfor.
Måske kan være fordi jeg hele tiden kopierer hele rækken, fremfor kun de celler som har indhold.

Men godt du har fået en delvis løsning :-)
jensen363 Seniormester
24. juli 2019 - 11:32 #20
Sub discoutdato()

Dim intLastRowNo As Integer
Dim r As Integer
Dim p As Integer
Dim r2 As Long
Dim FromDate As Date
Dim ToDate As Date
Dim intNumberDiscountLines As Integer
Dim ColNum As Integer

Sheets("DataSheet_2").Rows("2:250000").Delete Shift:=xlUp

With Sheets("DataSheet_1")
    intLastRowNo = .Cells(Rows.Count, "A").End(xlUp).Row
    r2 = 1
    For r = 2 To intLastRowNo
        FromDate = Sheets("DataSheet_1").Cells(r, 2).Value
        ToDate = Sheets("DataSheet_1").Cells(r, 3).Value
       
        intNumberDiscountLines = DateDiff("d", FromDate, ToDate) + 0
   
        For p = 1 To intNumberDiscountLines
            r2 = r2 + 1
            ColNum = 1
            Do While .Cells(1, ColNum) <> ""
                Sheets("DataSheet_2").Cells(r2, ColNum) = .Cells(r, ColNum)
                ColNum = ColNum + 1
            Loop
            Sheets("DataSheet_2").Cells(r2, 4) = Sheets("DataSheet_2").Cells(r2, 2) + p - 1
        Next
    Next
End With

MsgBox "Update ended"

End Sub
Jan Hansen Ekspert
24. juli 2019 - 11:47 #21
Denne macro virker:

Macro navn BehandelData, de andre er under makroer for overblik


Option Explicit

Dim wb As Workbook
Dim wsData As Worksheet, wsBehandlet As Worksheet
Dim Area As Range
Dim ArrData() As Variant, ArrBehandlet() As Variant
Dim CountA As Integer, CountB As Integer, Count As Integer
Dim NewRow As Integer, MyRow As Integer

Sub BehandelData()
    SetVar
    BeregnRækker
    NewArray
    Indsæt
End Sub
Private Sub Indsæt()
    Set Area = wsBehandlet.Range("A2")
    Set Area = Range(Area, Area.Offset(NewRow - 1, 3))
    Area.Value = ArrBehandlet
End Sub
Private Sub NewArray()
    ReDim ArrBehandlet(1 To NewRow, 1 To 4)
    Count = 0
    For CountA = LBound(ArrData, 1) + 1 To UBound(ArrData, 1)
        MyRow = DateDiff("d", ArrData(CountA, 2), ArrData(CountA, 3))
        For CountB = 1 To MyRow + 1
            Count = Count + 1
            ArrBehandlet(Count, 1) = ArrData(CountA, 1)
            ArrBehandlet(Count, 2) = DateValue(ArrData(CountA, 2))
            ArrBehandlet(Count, 3) = DateValue(ArrData(CountA, 3))
            ArrBehandlet(Count, 4) = DateValue(ArrData(CountA, 2)) + (CountB - 1)
        Next
    Next
End Sub

Private Sub BeregnRækker()
    For CountA = LBound(ArrData, 1) + 1 To UBound(ArrData, 1)
        NewRow = DateDiff("d", ArrData(CountA, 2), ArrData(CountA, 3)) + NewRow + 1
    Next
End Sub

Private Sub SetVar()
    Set wb = ThisWorkbook
    Set wsData = wb.Sheets("Data") 'Navnet på Data arket
    Set wsBehandlet = wb.Sheets("Beregnet Data") 'Navnet på Behandlings arket
    Set Area = wsData.UsedRange
    ArrData = Area.Value
    NewRow = 0
End Sub


Jan
Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links

Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester





Premium
Efter rokade i KMD's direktion: Her er selskabets nye ledelse
En række af KMD's direktører har fået nye hatte efter en ledelsesrokade. En ny profil er hentet ind udefra, en direktør stopper og en tredje bytter titel ud med en anden. Se selskabet nye ledelse her.
Computerworld
Statens Serum Institut har slettet alle sendte mails ved en fejl: "Det er dybt beklageligt"
Alle sendte mails fra Statens Seruminstitut og Sundhedsdatastyrelsen er blevet slettet, hvis de er sendt før 22. juli, oplyser de to myndigheder.
CIO
Torben Fabrin og Arla måtte på få dage omstille hele deres produktion da coronaen ramte
Da coronaen ramte verden måtte mejerigiganten Arla på få dage omstille sin produktion. Samtidig voksede salget massivt til supermarkeder mens institutioner og restauranter gik næsten i stå. Hør hvordan Arla kom gennem krisen ved blandt andet være klar med realtime analytics.
Job & Karriere
På jagt efter et it-job i Jylland? Her er 10 stillinger fra Aabenraa til Aalborg, der ledige netop nu
Vi har fundet en række spændende stillinger til dig, der jagter et it-job. Her kan du vælge og vrage mellem ledige stillinger lige fra Aabenraa til Aalborg.
White paper
Sådan sikrer du hovednøglen til jeres data
80% af alle ransomwareangreb skyldes misbrug af privilegerede brugeradgange. Ved at begrænse og overvåge adfærden på de privilegerede konti samt kontrollere mængden af tildelte rettigheder kan du mindske skaden ved hackerangreb mod din virksomhed og i visse tilfælde helt blokere dem. Internt kan du bruge kontrollen med brugeradgange til at dokumentere, hvem der bevæger sig i hvilke systemer, og hvad der foregår derinde. Privilegeret brugerstyring har de seneste to år stået øverst på Gartners Top10-liste over it-sikkerhedsprojekter, der bør få højeste prioritet. Alligevel er teknologien kun så småt ved at finde fodfæste i Danmark. Det kan viden om åbenlyse gevinster, relativ kort implementeringstid og yderst rimeligt budget være med til at ændre på. I dette whitepaper folder vi temaet privilegeret brugerstyring ud og placerer teknologien i det væld af prioriteringer, som CISO’en hver dag skal foretage.