MS Excel

Zdravím každému kdo má chvilku mi pomoci k úspěšnému cíli.
Problém:
- na listu data je řada dat, které se bohužel navzájem různě překrývají. Tyto data rozsekávám po 15min na listu Výsledek, kde zároveň odstraňuji duplicity, tzn. odstraním překryvy. Bohužel při rozsekávání dat po 15min mi makro občas nebere v potaz prvních nebo posledních 15min

- na listu Tabulky je další makro, které prohledává zda-li datum nespadá do uvedeného rozmezí dat a v případe Thrue přičte hodnotu z vedlejšího sloupce. Bohužel tyto výsledky se neshodují se součtem celého sloupce a přitom by samozřejmě měl

Nenašel jsem možnost přidání přílohy tak přidávám data a obě makra

Výpadek prostředí od (datum) Výpadek od (hodin)
23.7.12 9:00 24.7.12 11:20
24.7.12 13:00 24.7.12 14:00
27.7.12 8:20 27.7.12 9:20
27.7.12 13:15 27.7.12 14:15
2.8.12 9:20 2.8.12 10:20
7.8.12 11:00 7.8.12 15:00
7.8.12 15:30 13.8.12 14:00
9.8.12 9:00 9.8.12 14:00
16.8.12 10:40 16.8.12 11:40
17.8.12 9:00 17.8.12 13:20
24.8.12 15:50 13.9.12 10:00
3.9.12 11:35 3.9.12 12:10
4.9.12 11:10 4.9.12 12:10
5.9.12 12:20 5.9.12 13:20
5.9.12 13:00 5.9.12 15:50
5.9.12 13:00 4.10.12 11:30
6.9.12 11:40 6.9.12 12:15
6.9.12 18:00 7.9.12 9:00
10.9.12 14:05 10.9.12 14:51
11.9.12 11:50 11.9.12 12:32
12.9.12 11:00 20.9.12 12:00
13.9.12 9:00 14.9.12 17:00
13.9.12 9:00 14.9.12 17:00
13.9.12 11:30 13.9.12 17:20
14.9.12 11:30 14.9.12 13:12
17.9.12 15:00 17.9.12 16:08
17.9.12 16:45 17.9.12 17:00
17.9.12 16:45 17.9.12 17:00
18.9.12 10:00 18.9.12 10:17
18.9.12 10:00 18.9.12 10:17
18.9.12 11:00 18.9.12 13:12
19.9.12 9:00 19.9.12 9:40
19.9.12 9:00 19.9.12 9:40
19.9.12 9:00 19.9.12 9:40
19.9.12 11:30 19.9.12 12:50
19.9.12 15:10 19.9.12 16:05
19.9.12 16:20 19.9.12 16:33
19.9.12 16:20 19.9.12 16:33
21.9.12 13:05 21.9.12 14:14
24.9.12 14:15 24.9.12 15:35
25.9.12 12:15 25.9.12 13:25
25.9.12 13:15 25.9.12 14:15
26.9.12 13:00 26.9.12 14:45

Sub Hodinar()
Dim i As Integer
Dim ClcStart As String
Dim TimeStart As Date
Dim DayStart As Date
Dim ClcStop As String
Dim TimeStop As Date
Dim DayStop As Date
Dim Gap As String
Dim TimeMax As Date
Dim TimeMin As Date
Dim radek As String
Dim m As String
Dim n As String
Dim Posledni As Long

m = "2"
Gap = " "
minut = "96" 'rozsekani datumu po 15min
TimeMax = "18:00" 'maximalni hodnota prac doby
TimeMin = "8:00" 'minimalni hodnota prac doby
svatek = List1.Range("O02:O37")
radek = "0"

If WorksheetFunction.CountA(List2.Cells) > 0 Then
Posledni = List2.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
Posledni = Posledni + 1
For i = 2 To Posledni
If IsEmpty(List2.Cells(i, 1)) = False Then
ClcStart = (List2.Cells(i, 1))
MyPos = InStr(ClcStart, Gap)
If (MyPos > 0) Then
DayStart = Left(ClcStart, MyPos - 1)
TotPos = Len(ClcStart)
TotPos = TotPos - MyPos
TimeStart = Right(ClcStart, TotPos)
TimeStart = Round((TimeStart + "0:02") * minut, 0) / minut
End If
ClcStop = (List2.Cells(i, 2))
MyPos = InStr(ClcStop, Gap)
If (MyPos > 0) Then
DayStop = Left(ClcStop, MyPos - 1)
TotPos = Len(ClcStop)
TotPos = TotPos - MyPos
TimeStop = Right(ClcStop, TotPos)
TimeStop = Round((TimeStop + "0:02") * minut, 0) / minut
End If
End If

'slouzi pro kopirovani dalsich sloupcu
'n = i
Day1 = DayStart

If (Application.WorksheetFunction.NetworkDays(DayStart, DayStop, svatek) = 1) Then

If (Weekday(DayStop) = 7 Or Weekday(DayStop) = 1) Then
TimeStop = TimeMax
ElseIf (Weekday(DayStart) = 7 Or Weekday(DayStart) = 1) Or (Application.WorksheetFunction.NetworkDays(DayStart, DayStart, svatek) <> 1) Then
TimeStart = TimeMin
DayStart = DayStop
End If

If (TimeStart >= TimeMin And TimeStop > TimeMax) Then
TimeStop = TimeMax
ElseIf (TimeStart < TimeMin And TimeStop <= TimeMax) Then
TimeStart = TimeMin
ElseIf (TimeStart < TimeMin And TimeStop > TimeMax) Then
TimeStart = TimeMin
TimeStop = TimeMax
End If

Do While TimeStart <= TimeStop
List15.Cells(m, 1).Value = Format(DayStart, "Short Date")
'List15.Cells(m, 1).Select
'ActiveCell.FormulaR1C1 = DayStart
List15.Cells(m, 2).Value = Format(TimeStart, "Short Time")
'slouzi pro kopirovani dalsich sloupcu
'List2.Range("D" + n + ":R" + n).Copy
'List15.Range("C" + m + ":Q" + m).PasteSpecial
m = m + 1
radek = radek + 1
TimeStart = TimeStart + 1 / minut
Loop

ElseIf (Application.WorksheetFunction.NetworkDays(DayStart, DayStop, svatek) > 1) Then

For j = 1 To (DateDiff("d", DayStart, DayStop)) + 1
If (Application.WorksheetFunction.NetworkDays(Day1, Day1, svatek)) Then
If (Day1 = DayStart) And (TimeStart >= TimeMin) Then
zacatek = TimeStart
konec = TimeMax
ElseIf (Day1 = DayStart) And (TimeStart < TimeMin) Then
zacatek = TimeMin
konec = TimeMax
ElseIf (Day1 > DayStart) And (Day1 < DayStop) Then
zacatek = TimeMin
konec = TimeMax
ElseIf (Day1 = DayStop) And (TimeStop <= TimeMax) Then
zacatek = TimeMin
konec = TimeStop
ElseIf (Day1 = DayStop) And (TimeStop > TimeMax) Then
zacatek = TimeMin
konec = TimeMax
End If

Do While zacatek <= konec
List15.Cells(m, 1).Value = Format(Day1, "Short Date")
'List15.Cells(m, 1).Select
'ActiveCell.FormulaR1C1 = Day1
List15.Cells(m, 2).Value = Format(zacatek, "Short Time")
'List2.Range("D" + n + ":R" + n).Copy 'slouzi pro kopirovani dalsich sloupcu
'List15.Range("C" + m + ":Q" + m).PasteSpecial 'slouzi pro kopirovani dalsich sloupcu
m = m + 1
radek = radek + 1
zacatek = zacatek + 1 / minut
Loop

End If
Day1 = Day1 + (1 / 24 * 24)
Next j
ElseIf (Weekday(DayStart) <> 1 Or Weekday(DayStart) <> 7) And (Weekday(DayStop) <> 1 Or Weekday(DayStop)) Then
List2.Cells(i, 19).Interior.Color = RGB(255, 192, 0)
List2.Cells(i, 19).Font.Bold = True
List2.Cells(i, 19).HorizontalAlignment = xlCenter
List2.Cells(i, 19) = "Weekend"
End If
Next i
'vyrazuje duplicity
radek = radek + 1
List15.Range("$A$2:$B$" + radek).Select
List15.Range("$A$2:$B$" + radek).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

End Sub

Sub archiv()
Dim i As Integer
Dim zacatek As Date
Dim konec As Date
Dim datum As Date
Dim chyba As String

m = "54" 'zaèínající øádek

If WorksheetFunction.CountA(List6.Cells) > 0 Then
Posledni = List6.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
Posledni = Posledni - 1

For j = 1 To 9 'poèet cyklù
zacatek = List6.Cells(m, 9)
konec = List6.Cells(m, 10)
List6.Cells(m, 13) = "0"
For i = 3 To Posledni 'poèet øádkù s daty
datum = List6.Cells(i, 1)
chyb = List6.Cells(i, 3)
If (zacatek <= datum) And (datum <= konec) Then
List6.Cells(m, 13) = (List6.Cells(m, 13)) + chyb
List6.Cells(i, 1).Font.Bold = True
End If
Next i
m = m + 1
Next j
End Sub

Zaslat odpověď >

marjankaj(14.8.2014 17:24)#021156

A čo sa tak zaregistrovať????citovat

Bazz(14.8.2014 17:40)#021158

Ahoj,
je to opravdu nutnost? Není možné se se mnou bavit i takto?citovat

Opičák(14.8.2014 20:38)#021160

Marjankaj to myslel tak, že pokud se nezaregistruješ, tak nemáš možnost vložit přílohu.
Toto asi nikdo nebude chtít kopírovat a zkoušet jak to myslíš a jak to vlastně má fungovat. Takže se zaregistruj, nic to nechce ani nestojí a pak vložíš přílohu ve formátu zip.citovat

marjankaj(14.8.2014 20:39)#021161

Bazz napsal/a:

Ahoj,
je to opravdu nutnost? Není možné se se mnou bavit i takto?

Tak nutné to nie je. Ale ja si to nebudem prepisovať a lúštiť. Možno niekto iný sa bude chcieť zabaviť.

Keď sa zaregistruješ, tak budeš môcť priložiť prílohu.

http://wall.cz/index.php?m=topic&id=8351citovat

€Ł мσşqμΐτσ(15.8.2014 6:16)#021167

Mno tak já to chtěl zkusit, ale že to máš rozházený min. na třech listech s tím, že tam máš i nějaké svátky tak to jsem raději vzdal hned na začátku.

fakt by to chtělo tu přílohu.

citovat

Petr-kteremu-se-nedari(15.8.2014 14:15)#021174

Od rana jsem se pokousel sem dat tu pozadovanou prilohu asi 20x z x jiných prohlížečů. Ale teď už na to opravdu nemám nervy ani čas se "sra..." s tím jaký kod z obrázku mám opsat, když se mi žádný obrázek nezobrazí.

Tedy má-li někdo orpavdu zájem mi pomoci s makrem tak přikládám link na uloz.to

http://uloz.to/x47NmuP5/vypadky-testu-net-zipcitovat

Téma: Nesprávné hodnoty při rozsekávání datumu

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje