Private Sub Workbook_Open()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
If Now >= ISOYEARSTART(Year(Now)) And Now < ISOYEARSTART(Year(Now) + 1) Then
Sheet1.range("N3").Value = Year(Now) & Format(IsoWeekNumber(Now), "00")
MsgBox "Dabar yra: " & Year(Now) & Format(IsoWeekNumber(Now), "00")
ElseIf Now >= ISOYEARSTART(Year(Now) + 1) Then
Sheet1.range("N3").Value = Year(Now) + 1 & Format(IsoWeekNumber(Now), "00")
MsgBox "Dabar yra: " & Year(Now) + 1 & Format(IsoWeekNumber(Now), "00")
Else
Sheet1.range("N3").Value = Year(Now) - 1 & Format(IsoWeekNumber(Now), "00")
MsgBox "Dabar yra: " & Year(Now) - 1 & Format(IsoWeekNumber(Now), "00")
End If
If Sheet1.range("N3").Value <> Sheet1.range("S3").Value Then
Dim answer As Long
answer = MsgBox("Neatnaujinti duomenys pagal sia savaite. Ar norite atnaujinti duomenys?", vbYesNo + vbQuestion, "Einamosios savaites atnaujinimas")
If answer = vbYes Then
Sheet1.range("S3") = Sheet1.range("N3")
Dim isoyw As Long, pradzia As Long, pabaiga As Long, PFpabaiga As Long, Fpabaiga As Long, _
j As Long, prCol As Long, paCol As Long, FpaCol As Long, PFpaCol As Long, isoywCol As Long, _
datosNuo As Long, datosIki As Long, i As Long, h As Long
Dim Rpabaiga As Variant, RFpabaiga As Variant, RPFpabaiga As Variant, Rpradzia As Variant, Risoyw As Variant
Dim ThisSheet As Worksheet
Set ThisSheet = Sheet1
datosNuo = 0
With ThisSheet
For i = 1 To .Cells(11, Columns.Count).End(xlToLeft).Column
If Left(CStr(.Cells(11, i).Value), 2) = "20" Then
datosNuo = i
Exit For
End If
Next i
If datosNuo = 0 Then MsgBox "klaida datosNuo"
i = .Cells(11, Columns.Count).End(xlToLeft).Column
If Left(CStr(.Cells(11, i)), 2) = "20" Then
datosIki = i
Else
MsgBox "klaida datosIki"
End If
isoyw = .range("N3").Value
Set Risoyw = .range(Cells(11, datosNuo), Cells(11, datosIki)).Find(What:=isoyw, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not Risoyw Is Nothing Then isoywCol = Risoyw.Column
For j = 12 To 235
Application.StatusBar = "Processing row " & j & " of " & 235
' With Application
' .DisplayAlerts = True
' .ScreenUpdating = True
' .Calculation = xlCalculationAutomatic
' .EnableEvents = True
' End With
' With Application
' .ScreenUpdating = False
' .EnableEvents = False
' .Calculation = xlCalculationManual
' .DisplayAlerts = False
' End With
' End If
pabaiga = CLng(.Cells(j, 17).Value)
PFpabaiga = CLng(.Cells(j, 18).Value)
With range(Cells(11, datosNuo), Cells(11, datosIki))
Set Rpabaiga = .Find(What:=pabaiga, _
LookIn:=xlValues, _
LookAt:=xlWhole)
Set RPFpabaiga = .Find(What:=PFpabaiga, _
LookIn:=xlValues, _
LookAt:=xlWhole)
End With
If Not RPFpabaiga Is Nothing Then PFpaCol = RPFpabaiga.Column
If Not Rpabaiga Is Nothing Then paCol = Rpabaiga.Column
Fpabaiga = CLng(.Cells(j, 19).Value)
If (isoywCol > PFpaCol And Fpabaiga = 0) Or (isoywCol > paCol + 1 And Fpabaiga = 0) Then
.range(Cells(j, datosNuo), Cells(j, datosIki)).ClearContents
.range(Cells(j, datosNuo), Cells(j, datosIki)).UnMerge
.range(Cells(j, datosNuo), Cells(j, datosIki)).Interior.ColorIndex = 0
pradzia = CLng(.Cells(j, 16).Value)
If pradzia > 0 And pabaiga > 0 And pradzia <= pabaiga Then
With range(Cells(11, datosNuo), Cells(11, datosIki))
Set Rpradzia = .Find(What:=pradzia, _
LookIn:=xlValues, _
LookAt:=xlWhole)
Set RFpabaiga = .Find(What:=Fpabaiga, _
LookIn:=xlValues, _
LookAt:=xlWhole)
End With
If Not Rpradzia Is Nothing Then prCol = Rpradzia.Column
If Not RFpabaiga Is Nothing Then FpaCol = RFpabaiga.Column
If Fpabaiga > 0 And pabaiga > 0 And pradzia > 0 Then
If Fpabaiga <= pabaiga Then
If pabaiga = pradzia Or pradzia = Fpabaiga Then
'MsgBox "M-" & Fpabaiga
.Cells(j, FpaCol).Value = "A"
.Cells(j, FpaCol).Interior.ColorIndex = 8
Else
'MsgBox "tikras rezis F: Z-" & pradzia & " - " & Cells(11, RFpabaiga.Column - 1) & " ; M-" & Fpabaiga
dal1 = (FpaCol - prCol) \ 6
If dal1 > 1 Then
For h = 1 To (dal1 - 1)
.range(.Cells(j, prCol), .Cells(j, prCol + 5)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
'msgbox h & " " & prCol & "-" & prCol + 5
prCol = prCol + 6
Next h
.range(.Cells(j, prCol), .Cells(j, FpaCol - 1)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
Else
.range(.Cells(j, prCol), .Cells(j, FpaCol - 1)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
End If
.Cells(j, FpaCol).Value = "A"
.Cells(j, FpaCol).Interior.ColorIndex = 8
End If
ElseIf FpaCol - paCol = 1 Then
'MsgBox "tikras rezis F: Z-" & pradzia & " - " & pabaiga & " ; Gel-" & Fpabaiga
dal1 = (paCol - prCol + 1) \ 6
If dal1 > 1 Then
For h = 1 To (dal1 - 1)
.range(.Cells(j, prCol), .Cells(j, prCol + 5)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
'msgbox h & " " & prCol & "-" & prCol + 5
prCol = prCol + 6
Next h
.range(.Cells(j, prCol), .Cells(j, paCol)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
Else
.range(.Cells(j, prCol), .Cells(j, paCol)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
End If
.Cells(j, FpaCol).Value = "Av"
.Cells(j, FpaCol).Interior.ColorIndex = 44
Else
'MsgBox "tikras rezis F: Z-" & pradzia & " - " & pabaiga & " ; Ru-" & Cells(11, Rpabaiga.Column + 1) & " - " & Cells(11, RFpabaiga.Column - 1) & " ; Gel-" & Fpabaiga
dal1 = (paCol - prCol + 1) \ 6
If dal1 > 1 Then
For h = 1 To (dal1 - 1)
.range(.Cells(j, prCol), .Cells(j, prCol + 5)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
'msgbox h & " " & prCol & "-" & prCol + 5
prCol = prCol + 6
Next h
.range(.Cells(j, prCol), .Cells(j, paCol)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
Else
.range(.Cells(j, prCol), .Cells(j, paCol)).Merge
.Cells(j, prCol).Value = .Cells(j, 9).Value
.Cells(j, prCol).Interior.ColorIndex = 4
End If
'******************* antras
dal1 = (FpaCol - 1 - paCol + 1 + 1) \ 6
If dal1 > 1 Then
For h = 1 To (dal1 - 1)
.range(.Cells(j, paCol + 1), .Cells(j, paCol + 1 + 5)).Merge
.Cells(j, paCol + 1).Value = .Cells(j, 9).Value
.Cells(j, paCol + 1).Interior.ColorIndex = 46
'msgbox h & " " & paCol + 1 & "-" & paCol + 1 + 5
prCol = prCol + 6
Next h
.range(.Cells(j, paCol + 1), .Cells(j, FpaCol - 1)).Merge
.Cells(j, paCol + 1).Value = .Cells(j, 9).Value
.Cells(j, paCol + 1).Interior.ColorIndex = 46
Else
.range(.Cells(j, paCol + 1), .Cells(j, FpaCol - 1)).Merge
.Cells(j, paCol + 1).Value = .Cells(j, 9).Value
.Cells(j, paCol + 1).Interior.ColorIndex = 46
End If
.Cells(j, FpaCol).Value = "Av"
.Cells(j, FpaCol).Interior.ColorIndex = 44
End If
LinkBack URL
About LinkBacks
selectio 
Register To Reply
Bookmarks