wys.docx

VBA workbooks.open w select case

Daje kod w plik word. Zaznaczyłem na zielono gdzie jest problem. Jeśli nie ma pliku (case 15) to chciałbym aby aby przeszedł do case 16 i kolejne kroki robił dla niego


Function IsoWeekNumber(data As Date) As Integer
IsoWeekNumber = Format(data, " ww " , vbMonday, vbFirstFourDays) - 1 'obliczamy tydzien do tylu
If IsoWeekNumber & gt; 52 Then
If Format(data + 7, " ww " , vbMonday, vbFirstFourDays) = 2 Then
IsoWeekNumber = 1
End If
End If
End Function

Sub uzup_all_lines()
'oblicz automatycznie róznice miedzy zaplanowana produkcja a rzeczywista
'
'
Call zapis 'zapisuje aktualny plik w razie problemów
Dim ilerowsob As Long 'sob-pt arkusz
Dim ilerowover As Long ' over & under arkusz
Dim ilerowdevia As Long 'deviations arkusz
Dim i As Integer, z As Integer 'pętla dla 16lini +total

Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Application.Calculation = xlmanual
'Application.EnableEvents = False

Sheets( " Deviations " ).Select
Dim licznikdowk As Long
licznikdowk = Cells(Rows.Count, 1).End(xlUp).Row

For i = 15 To 15

Call CzyscNowe
'
'

Dim arkusze As Workbook
Dim sci As String
Dim podst_arkusz As Workbook
Set podst_arkusz = ThisWorkbook ' arkusz z makrem
Dim zamknijdanyarkusz As String ' tylko pobieramy dane i zamykamy
Select Case i

Case 2:
'friday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " A " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " A " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing


Case 3:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " B " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " B " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 4:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " C " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " C " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 5:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " G " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " G " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 6:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " H " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " H " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 7:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " I " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " I " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 8:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " J " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " J " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 9:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " K " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " K " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 10:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " L " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " L " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 11:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " M " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " M " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 12:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " N " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " N " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 13:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " O " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " O " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 14:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " P " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " P " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 15:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " Q " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " Q " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 16:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed wk " & IsoWeekNumber(Date) & " " & " R " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \Produced wk " & " " & IsoWeekNumber(Date) & " _ LINE " & " R " )
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
Case 17:
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \fixed " & " \Fixed All wk " & IsoWeekNumber(Date))
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Friday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing

'monday
Set arkusze = Workbooks.Open( " C:\Users\ " & Environ( " UserName " ) & " \Desktop\OR\wk " & " " & IsoWeekNumber(Date) & " \Produced " & " \produced all wk " & IsoWeekNumber(Date))
zamknijdanyarkusz = ActiveWorkbook.Name
Range( " A:T " ).CurrentRegion.Select
Selection.Copy
podst_arkusz.Activate
Sheets( " Monday " ).Select
Range( " A1 " ).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(zamknijdanyarkusz).Close SaveChanges:=False
Set arkusze = Nothing
End Select
'
'
'
Call OrR


On Error Resume Next

Sheets( " monday " ).Select
Range( " N3:U3 " ).Copy

Dim datval As Date
Dim mamymiesiac As Integer
datval = Now()
mamymiesiac = Month(datval) 'aby znalezc arkusz odpowiadajacy aktualnego miesiaca (nie wolno zmieniac pozycji arkuszy)
Sheets(mamymiesiac).Select


' b = 1
' For z = b To Max ' ile jest rows 'petla zastepcza(moze szybsza niz select case
' If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
' Cells(z, 1).Select
' ActiveCell.Offset(0, 1).Select
' Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
' xlNone, SkipBlanks:=False, Transpose:=False
' b = b + 7
' End If
'Next z

Dim gdzie As Long
' For gdzie = 1 To 160
' If Cells(gdzie, 1) = " A " Then
' MsgBox gdzie
' End If
'Next gdzie
'End Sub

Select Case i 'wypelnia poszczegolne miesiace
Case 2 'linia a
For gdzie = 1 To 150
If Cells(gdzie, 1) = " A " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie

Case 3 'linia b
For gdzie = 5 To 150 'zwiekszam gdzie poniewaz nie oplaca sie zawsze zaczynac od 1, - przed b jest linia a
If Cells(gdzie, 1) = " B " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
Next z
End If
Next gdzie
Case 4
For gdzie = 10 To 150
If Cells(gdzie, 1) = " C " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 5
For gdzie = 15 To 150
If Cells(gdzie, 1) = " G " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 6 ' linia h
For gdzie = 20 To 150
If Cells(gdzie, 1) = " H " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 7
For gdzie = 25 To 150
If Cells(gdzie, 1) = " I " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 8
For gdzie = 30 To 150
If Cells(gdzie, 1) = " J " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 9
For gdzie = 35 To 150
If Cells(gdzie, 1) = " K " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 10
For gdzie = 40 To 150
If Cells(gdzie, 1) = " L " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 11
For gdzie = 45 To 150
If Cells(gdzie, 1) = " M " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 12 'linia N
For gdzie = 50 To 150
If Cells(gdzie, 1) = " N " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 13
For gdzie = 55 To 150
If Cells(gdzie, 1) = " O " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 14
For gdzie = 60 To 150
If Cells(gdzie, 1) = " Q " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 15
For gdzie = 65 To 150
If Cells(gdzie, 1) = " P " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 16
For gdzie = 70 To 150
If Cells(gdzie, 1) = " R " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
Case 17 'total
For gdzie = 75 To 150
If Cells(gdzie, 1) = " TOTAL " Then

For z = gdzie + 1 To gdzie + 5
If Cells(z, 1).Value Like " wk " & IsoWeekNumber(Date) Then
Cells(z, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

End If
Next z
End If
Next gdzie
End Select


Sheets( " Monday " ).Select
Range( " Q3 " ).Select
Application.CutCopyMode = False
Selection.Copy
Sheets( " sob-pt " ).Select
ilerowsob = Cells(Rows.Count, 1).End(xlUp).Row + 1 'pętla sub-pt
Cells(ilerowsob, i).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets( " Monday " ).Select
Range( " S3 " ).Select
Application.CutCopyMode = False
Selection.Copy
Sheets( " Over & under_prod " ).Select
ilerowover = Cells(Rows.Count, 1).End(xlUp).Row + 1 'pętla over
Cells(ilerowover, 2 * i - 2).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets( " Monday " ).Select
Range( " U3 " ).Select
Application.CutCopyMode = False
Selection.Copy
Sheets( " Over & under_prod " ).Select
Cells(ilerowover, 2 * i - 1).Select ' pętla over^ jak wyżej
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

If i = 17 Then GoTo omijamdeviation 'w arkuszu devations nie wklejamy dla " all " , tylko dla linii

Sheets( " Monday " ).Select
Dim e As Long 'kopiuje powyzej 96%
Rows( " 1:1 " ).Delete
For e = Cells(Rows.Count, " H " ).End(xlUp).Row To 1 Step -1
If Cells(e, 8).Value & gt; 0.965 Then Rows(e).Delete
Next e
Range( " A1 " ).CurrentRegion.Copy

Sheets( " Deviations " ).Select
ilerowdevia = Cells(Rows.Count, 1).End(xlUp).Row + 1 'pętla deviations
Cells(ilerowdevia, 1).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False

omijamdeviation:
Sheets( " deviations " ).Select

Dim casei2 As Double
casei2 = Cells(Rows.Count, 1).End(xlUp).Row - 1
Cells(ilerowdevia, 11).Select



Select Case i ' wpisywanie lini A-R w ark - deviations
Case 2

For n = 1 To casei2 - ilerowdevia + 2 ' dodajemy 2 z powodu raz odjecia -1 (w cansei2) a raz dodania + 1 (ilerowdevia)
ActiveCell.Value = " A "
ActiveCell.Offset(1, 0).Select
Next n

Case 3

Cells(ilerowdevia, 11).Value " B "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " B "
ActiveCell.Offset(1, 0).Select
Next n
Case 4

Cells(ilerowdevia, 11).Value " C "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " C "
ActiveCell.Offset(1, 0).Select
Next n
Case 5

Cells(ilerowdevia, 11).Value " G "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " G "
ActiveCell.Offset(1, 0).Select
Next n
Case 6

Cells(ilerowdevia, 11).Value " H "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " H "
ActiveCell.Offset(1, 0).Select
Next n
Case 7

Cells(ilerowdevia, 11).Value " I "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " I "
ActiveCell.Offset(1, 0).Select
Next n
Case 8

Cells(ilerowdevia, 11).Value " J "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " J "
ActiveCell.Offset(1, 0).Select
Next n
Case 9

Cells(ilerowdevia, 11).Value " K "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " K "
ActiveCell.Offset(1, 0).Select
Next n
Case 10

Cells(ilerowdevia, 11).Value " L "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " L "
ActiveCell.Offset(1, 0).Select
Next n
Case 11

Cells(ilerowdevia, 11).Value " M "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " M "
ActiveCell.Offset(1, 0).Select
Next n
Case 12

Cells(ilerowdevia, 11).Value " N "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " N "
ActiveCell.Offset(1, 0).Select
Next n
Case 13

Cells(ilerowdevia, 11).Value " O "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " O "
ActiveCell.Offset(1, 0).Select
Next n
Case 14

Cells(ilerowdevia, 11).Value " P "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " P "
ActiveCell.Offset(1, 0).Select
Next n
Case 15

Cells(ilerowdevia, 11).Value " Q "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " Q "
ActiveCell.Offset(1, 0).Select
Next n
Case 16

Cells(ilerowdevia, 11).Value " R "
For n = 1 To casei2 - ilerowdevia + 2
ActiveCell.Value = " R "
ActiveCell.Offset(1, 0).Select
Next n

End Select


Next i

' by zrobić np wk40/2017
Dim informcell As Long

Sheets( " Over & under_prod " ).Select
informcell = Cells(Rows.Count, 2).End(xlUp).Row
Rows(informcell).Select
Selection.NumberFormat = " 0.00% "
Cells(informcell, 1).Select
Selection.Value = " wk " & IsoWeekNumber(Date) & " / " & Year(Date) 'tu zmienilem z kweek na iso

Sheets( " sob-pt " ).Select
informcell = Cells(Rows.Count, 2).End(xlUp).Row
Rows(informcell).Select
Selection.NumberFormat = " 0.00% "
Cells(informcell, 1).Select
Selection.Value = " wk " & IsoWeekNumber(Date) & " / " & Year(Date)

Sheets( " deviations " ).Select
Dim countnow As Long
Dim roznica As Long
Dim u As Double
countnow = Cells(Rows.Count, 1).End(xlUp).Row + 1
roznica = countnow - licznikdowk - 1

Cells(licznikdowk + 1, 12).Select
For u = 1 To roznica
ActiveCell.Value = IsoWeekNumber(Date) & " wk " & " / " & Year(Date)
ActiveCell.Offset(1, 0).Select
Next u

'Application.EnableEvents = True
'Application.Calculation = xlAutomatic
Application.CutCopyMode = False
Application.DisplayAlerts = True

End Sub


Pobierz plik - link do postu