Verificare daca sunt deschise alte workbookuri excel

zvonacfirst · Mesaj de **zvonacfirst** » Mar Oct 10, 2017 12:16 pm

Salut.

Am un workbook pe server care este utilizat de mai multi colegi si acesti colegi se plang de anumite probleme pe care le au daca mai au deschise si alte workbookuri excel in acelasi timp.
Workbookul meu porneste cu un userform ascunzand Excel ceea ce face ca celelalte workbookuri sa nu fie vizibile. Apoi butoanele de pe userform deschid doar cate un sheet in full screen (deoarece este vorba de tabele si vizualizarea ribbonurilor nu este necesara). De aici iarasi problemele, toate celelalte worksheeturi deschise se deschid full screen.
Am cautat pe forum si pe net si nu am gasit un cod care sa verifice daca sunt deschise alte worksheeturi, sa apara un msgbox de genul "Trebuie sa inchideti toate celelalte worksheeturi Excel" si sa nu deschida worksheetul respectiv.
Codul nu trebuie sa fie legat de denumirea workbookurilor deschise deoarece sunt multi utilizatori si denumirile fisierelor excel deschise nu pot fi prevazute.
Nu pot atasa worksheetul deoarece este masiv, are multe sheeturi, multe informatii si este personalizat. Sper ca m-am facut inteles.
Multumesc.

Mesaj de **IPP** » Mar Oct 10, 2017 1:11 pm

Buna ziua

Mesajul dvs. are niste neclaritati in folosirea unor termeni. Asadar:
Workbook = fisier excel (sau Registru de calcul); Worksheet = foaie dintr-un fisier excel.

Daca am inteles bine din titlul topicului, atunci, ar trebui sa existe un cod care sa ruleze automat la deschiderea fisierului dvs., inainte de orice.

Cod: Selectaţi tot

If Workbooks.Count > 1 Then
 MsgBox "Nu puteti folosi acest fisier daca aveti si alte fisiere Excel deschise." & Chr(10) & _
 "(Salvati si) Inchideti toate fisierele Excel si incercati din nou"
 ThisWorkbook.Close
End If

IP

zvonacfirst · Mesaj de **zvonacfirst** » Mar Oct 10, 2017 3:35 pm

Multumesc mult.
Scuze pentru exprimarea neclara.
Merge brici.
Ati reformulat si mesajul... este perfect.

Nills · Mesaj de **Nills** » Mie Oct 11, 2017 11:54 am

In cazul tau cred ca mai bine corectezi codul din fisierul de pe server, de asa maniera incat sa nu se "atinga" de fisierele excel, deschise pe calculatoarelor userilor...

zvonacfirst · Mesaj de **zvonacfirst** » Mie Oct 11, 2017 12:38 pm

"Sa nu se atinga" in sensul de a nu le influenta functionarea? Sau de a nu le "imprumuta" setarile? Am o problema de exemplu cu rularea acelui fisier de pe server in fuu screen. Toate celelate deschise in paralel se deschid in full screen.
Ce trebuie sa fac pentru asta? M-ati pierdut pe traseu.

Nills · Mesaj de **Nills** » Mie Oct 11, 2017 7:11 pm

Posteaza codul VBA din UserForm (si modul daca exista) si poate putem sa-l modificam.

zvonacfirst · Mesaj de **zvonacfirst** » Joi Oct 12, 2017 9:53 am

Ok. Multumesc pentru ajutor.
Dar va rog sa nu ma criticati foarte tare. Poate codurile mele nu au simplitatea, limpezimea si coerenta unora scrise de specialisti dar sunt functionale desi sunt "de adunatura".

In ThisWorkbook:

Cod: Selectaţi tot

Private Sub Workbook_Open()
    'frmEvaluare.Show vbModeless
    
   If Workbooks.Count > 1 Then
    MsgBox "Nu puteti folosi acest fisier daca aveti si alte fisiere Excel deschise." & Chr(10) & _
    "(Salvati si) Inchideti toate fisierele Excel si incercati din nou"
    ThisWorkbook.Close
    End If

    Application.ScreenUpdating = False
    Application.Visible = True
    Application.DisplayFullScreen = True
    Application.DisplayFormulaBar = False
    ActiveWindow.DisplayWorkbookTabs = False
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
        
    Sheets("Splash").Visible = True
    
    Range("A1:Z1").Select
        ActiveWindow.Zoom = True
        Range("B2").Select
    
    For Each ws In Worksheets
    If ws.Name <> "Splash" Then ws.Visible = False
    Next ws

    'Range("B2").Select
    Application.ScreenUpdating = True
End Sub

'Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'Application.Visible = True
'End Sub

'Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Cancel = Not BooleanForClosing
    'If Cancel = True Then
        'MsgBox "Utilizati butonul FINALIZARE", vbOKOnly, "Actiune nepermisa"
    'End If
'End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)

If Not PrintOK Then Cancel = True
End Sub

In userform:

Cod: Selectaţi tot

Option Explicit


Private Sub UserForm_Initialize()
If Sheet13.Range("F2").Value <> vbNullString Then
    MsgBox " Aceasta evaluare a fost validata in data de" & " " & Sheet13.Range("F2").Value & "." & vbNewLine & "   - Puteti vizualiza continutul." & vbNewLine & "   - Editarea nu este posibila."
    frmEvaluare.Label3.Caption = "Evaluarea a fost validata in data de" & " " & Sheet13.Range("F2").Value & vbNewLine & "   - Vizualizarea este posibila." & vbNewLine & "   - Editarea nu este posibila."
Else
    frmEvaluare.Label3.Caption = " Evaluarea nu este validata." & vbNewLine & " - Vizualizarea este posibila." & vbNewLine & " - Editarea este posibila."
End If

If Sheet13.Range("F2").Value = vbNullString Then
    Me.CommandButton20.Enabled = True
    Me.CommandButton17.Enabled = False
Else
    Me.CommandButton20.Enabled = False
    Me.CommandButton17.Enabled = True
End If
End Sub

Public Function HasContent(text_box As Object) As Boolean
HasContent = (Len(Trim(TextBox1.Value)) > 0)
End Function

Private Sub CommandButton1_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P1
    frmEvaluare.Hide
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P2
    frmEvaluare.Hide
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton3_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P3
    frmEvaluare.Hide
End Sub

Private Sub CommandButton4_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P3_3
    frmEvaluare.Hide
End Sub

Private Sub CommandButton5_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P4
    frmEvaluare.Hide
End Sub

Private Sub CommandButton6_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P5
    frmEvaluare.Hide
End Sub

Private Sub CommandButton7_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P6
    frmEvaluare.Hide
End Sub

Private Sub CommandButton8_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P6_3
    frmEvaluare.Hide
End Sub

Private Sub CommandButton9_Click()
 Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P8
    frmEvaluare.Hide
End Sub

Private Sub CommandButton10_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P9
    frmEvaluare.Hide
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton11_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Application.ScreenUpdating = False
    Call HideStuff
    Call Select_P10
    frmEvaluare.Hide
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton12_Click()
  ' salveaza si inchide workbookul
   Application.DisplayAlerts = False
   BooleanForClosing = True
    ' If ActiveWorkbook.ReadOnly Then
    ' MsgBox "ATENTIE!" & vbNewLine & "Ati ales sa deschideti aplicatia in modul Read Only." & vbNewLine & _
    ' "Modificarile pe care le-ati facut nu vor fi salvate." & vbNewLine & _
    ' "RISCATI PIERDEREA INFORMATIILOR" & vbNewLine & "" & vbNewLine & _
    ' "  - Apasati Cancel pentru a ramane in aplicatie." & vbNewLine & _
    ' "  - Utilizand optiunea File/Save As puteti salva aplicatia in computerul dvs fara a pierde datele introduse." & vbNewLine & _
    ' "  - Apasati OK daca doriti sa inchideti.", vbOKCancel, "AVERTISMENT!"
    
    ' Else
    Call ShowStuff

    ThisWorkbook.Save
    'Application.Visible = True
    
    ThisWorkbook.Close
    'Application.Quit
    'ActiveWorkbook.Close True
    ' End If
    Application.DisplayAlerts = True
End Sub

Private Sub CommandButton13_Click()
    ' Acces administrator
    
Dim ws As Worksheet
Dim strPasswd

    strPasswd = InputBox("Introduceti parola.", "Autorizare acces")

    'Check to see if there is any entry made to input box, or if
    'cancel button is pressed. If no entry made then exit sub.

    If strPasswd = "" Or strPasswd = Empty Then
        MsgBox "Nu ati introdus parola.", vbInformation, "Informatie necesara"
        Exit Sub
    End If

    'If correct password is entered open Employees form
    'If incorrect password entered give message and exit sub

    If strPasswd = "13021429" Then
        For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
        Next ws
        Application.DisplayFullScreen = False
        Application.DisplayFormulaBar = True
        ActiveWindow.DisplayWorkbookTabs = True
        ActiveWindow.DisplayHeadings = True
        ActiveWindow.DisplayGridlines = False
        Sheets("Administrare").Select
        
        Range("A1:V1").Select
        ActiveWindow.Zoom = True

        Range("A2").Select
        frmEvaluare.Hide
        
    Else
        MsgBox "Parola introdusa nu este corecta.", _
               vbOKOnly, "Nu se autorizeaza accesul."
        Exit Sub
    End If

    Application.Visible = True
    ActiveWindow.DisplayGridlines = False
End Sub

Private Sub CommandButton15_Click()
    Application.Visible = True
    ActiveWindow.DisplayHeadings = True
    ActiveWindow.DisplayGridlines = False
    Call HideStuff
    Call Select_EPI
    frmEvaluare.Hide
End Sub

Private Sub CommandButton20_Click()
    ' Valideaza fisierul

Dim ws As Worksheet
Dim strPasswd

    strPasswd = InputBox("Introduceti parola.", "Autorizare")

    'Check to see if there is any entry made to input box, or if
    'cancel button is pressed. If no entry made then exit sub.

    If strPasswd = "" Or strPasswd = Empty Then
        MsgBox "Nu ati introdus parola.", vbInformation, "Informatie necesara"
        Exit Sub
    End If

    'If correct password is entered open Employees form
    'If incorrect password entered give message and exit sub

    Sheet13.Range("F2") = Format(Date, "dd.mm.yyyy")
    Me.CommandButton20.Enabled = False
    Me.CommandButton17.Enabled = True
    Call ProtectAllCells

    If strPasswd = "1234" Then
        MsgBox "Validarea datelor a fost efectuata cu succes.", _
               vbOKOnly, "Validare reusita"
        frmEvaluare.Label3.Caption = "Evaluarea a fost validata in data de" & " " & Sheet13.Range("F2").Value & vbNewLine & "   - Vizualizarea este posibila." & vbNewLine & "   - Editarea nu este posibila."
        
    Else
        MsgBox "Parola introdusa nu este corecta.", _
               vbOKOnly, "Validarea datelor nu a fost efectuata."
        Me.CommandButton20.Enabled = True
        Me.CommandButton17.Enabled = False
        Exit Sub
    End If

End Sub

Private Sub CommandButton17_Click()
    ' Activeaza revizuirea
    
    Dim ws As Worksheet
    Dim strPasswd

    strPasswd = InputBox("Introduceti parola.", "Autorizare")
    
    If strPasswd = "" Or strPasswd = Empty Then
        MsgBox "Nu ati introdus parola.", vbInformation, "Informatie necesara"
        Exit Sub
    End If
    
    Call UnprotectAllCells
    Sheet13.Range("F2").ClearContents
        Me.CommandButton20.Enabled = True
    Me.CommandButton17.Enabled = False
    
        If strPasswd = "1234" Then
        MsgBox "Aceasta evaluare poate fi revizuita." & vbNewLine & "Dupa revizuire trebuie sa validati din nou.."
        frmEvaluare.Label3.Caption = "Evaluarea nu este validata." & vbNewLine & " - Vizualizarea este posibila." & vbNewLine & " - Editarea este posibila."
        
    Else
        MsgBox "Parola introdusa nu este corecta.", _
               vbOKOnly, "Revizuirea datelor nu este posibila."
        Me.CommandButton20.Enabled = False
        Me.CommandButton17.Enabled = True
        Exit Sub
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        MsgBox "Butonul ‘X’ nu inchide aplicatia. Utilizati butonul 'Inchidere'.", vbOKOnly, "Actiune nepermisa"
    End If
End Sub

In module:

Cod: Selectaţi tot

Public BooleanForClosing As Boolean
Sub Open_App()
    frmEvaluare.Show vbModeless
    Application.Visible = False
End Sub
Sub Select_EPI()
'
' Select_EPI Macro
'
    Application.ScreenUpdating = False
    Sheets("EPI").Visible = True
    ActiveWindow.ScrollRow = 1

    For Each ws In Worksheets
    If ws.Name <> "EPI" Then ws.Visible = False
    Next ws

    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
        ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P1()
'
' Select_P1 Macro
'
    Application.ScreenUpdating = False
    Sheets("P1-Delegari-Bugete").Visible = True
    ActiveWindow.ScrollRow = 1

    For Each ws In Worksheets
    If ws.Name <> "P1-Delegari-Bugete" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
        ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P2()
'
' Select_P2 Macro
'
    Application.ScreenUpdating = False
    Sheets("P2-Afaceri").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P2-Afaceri" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P3()
'
' Select_P3 Macro
'
    Application.ScreenUpdating = False
    Sheets("P3-Resurse umane").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P3-Resurse umane" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P3_3()
'
' Select_P3.3 Macro
'
    Application.ScreenUpdating = False
    Sheets("P3.3- Sanatate si securitate").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P3.3- Sanatate si securitate" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P4()
'
' Select_P4 Macro
'
    Application.ScreenUpdating = False
    Sheets("P4-Achizitii").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P4-Achizitii" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P5()
'
' Select_P5 Macro
'
    Application.ScreenUpdating = False
    Sheets("P5-Finante-Conta").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P5-Finante-Conta" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P6()
'
' Select_P6 Macro
'
    Application.ScreenUpdating = False
    Sheets("P6.1-6.2 Juridic").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P6.1-6.2 Juridic" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P6_3()
'
' Select_P6_3 Macro
'
    Application.ScreenUpdating = False
    Sheets("P6.3-Asigurari").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P6.3-Asigurari" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P8()
'
' Select_P8 Macro
'
    Application.ScreenUpdating = False
    Sheets("P8-Sisteme informatice").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P8-Sisteme informatice" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P9()
'
' Select_P9 Macro
'
    Application.ScreenUpdating = False
    Sheets("P9-Comunicare").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P9-Comunicare" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Select_P10()
'
' Select_P10 Macro
'
    Application.ScreenUpdating = False
    Sheets("P10-Mediu si resp.sociala").Visible = True
    ActiveWindow.ScrollRow = 1
    
    For Each ws In Worksheets
    If ws.Name <> "P10-Mediu si resp.sociala" Then ws.Visible = False
    Next ws
    
    Range("A1:L1").Select
    ActiveWindow.Zoom = True

    Range("A1").Select
    ActiveSheet.Unprotect "13021429"
    'ActiveWindow.DisplayWorkbookTabs = True
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub
Sub Inchidere()
ActiveWindow.ScrollRow = 1
Range("A1:Z1").Select
ActiveWindow.Zoom = True
Application.ScreenUpdating = False
ActiveSheet.Unprotect "13021429"
ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
ThisWorkbook.Save
ActiveSheet.EnableSelection = xlUnlockedCells
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayGridlines = False
Application.Visible = False
Application.ScreenUpdating = True
frmEvaluare.Show vbModeless
End Sub
Sub InsertNewRow()
    
    Dim rCell As Range
    Dim rRow As Range
    Dim rList As Range
    Dim nRow As Long
    Dim row As Range
    Dim neValues As Range
    Dim neFormulas As Range
    Dim MyRange As Range
   
    ActiveSheet.Unprotect "13021429"
    
    nRow = Val(InputBox("Introduceti numarul liniei sub care doriti sa se face inserarea." & vbNewLine & " " & vbNewLine & "ATENTIE!" & vbNewLine & "Este vorba despre numarul liniei din Excel nu despre numarul curent din tabel.", "Introducere date"))
    If nRow = 0 Then Exit Sub
   
    Set rRow = Intersect(ActiveSheet.Cells(nRow, 1).EntireRow, ActiveSheet.UsedRange)
    If rRow Is Nothing Then Exit Sub
    rRow.EntireRow.Select
   
    If rRow.MergeCells Then
    MsgBox "Actiune nepermisa." & vbCrLf & "Linia selectata contine celule comasate (merged cells)."
    rRow.Offset(1, 0).Cells(0, 1).Select
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    ActiveSheet.EnableSelection = xlUnlockedCells

    Exit Sub
    End If
    
    Set rCell = rRow.Offset(1, 0).Cells(0, 1)
    If rCell.Value = "Nr. crt." Then
    MsgBox "Actiune nepermisa." & vbCrLf & "Nu puteti introduce un nou cap de tabel."
    rRow.Offset(2, 0).Cells(0, 2).Select
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    ActiveSheet.EnableSelection = xlUnlockedCells

    Exit Sub
    End If
   
    Set MyRange = Columns("B:K")
    On Error Resume Next
    Set neValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlConstants), MyRange)
    Set neFormulas = Intersect(ActiveCell.EntireRow.SpecialCells(xlFormulas), MyRange)
    On Error GoTo 0
    
   If neValues Is Nothing And neFormulas Is Nothing Then
        MsgBox "Nu puteti introduce o linie noua sub o linie lipsita de continut."
        rRow.Offset(-1, 0).Cells(1, 0).Select
    Else
        rRow(1).Offset(1, 0).EntireRow.Insert
        rRow.Copy rRow.Cells(1).Offset(1, 0)
        Application.CutCopyMode = False
        Set rCell = rRow.Cells(1).Offset(1, 0).Resize(1, rRow.Columns.Count)
        On Error Resume Next
        rCell.SpecialCells(xlCellTypeConstants).ClearContents
        rRow.Offset(0, 1).Cells(1, 0).Select
        On Error GoTo 0
        Set rCell = Nothing
        Set rRow = Nothing
    End If
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
   
End Sub
Sub DeleteRow()

Dim firstrw As Long

ActiveSheet.Unprotect "13021429"

    
    If firstrw = 0 Then
        firstrw = Application.InputBox(prompt:="Indicati numarul liniei pe care doriti sa o stergeti." & vbNewLine & "" & vbNewLine & "ATENTIE!" & vbNewLine & "Este vorba despre numarul liniei din Excel nu despre numarul curent din tabel." _
        , Title:="Stergere date", Default:="")
    If firstrw = False Then Exit Sub
    End If

Cells(firstrw, "A").Select
ActiveCell.EntireRow.Delete
ActiveSheet.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
ActiveSheet.EnableSelection = xlUnlockedCells

End Sub

Sub Print_Active_Worksheet()
Application.DisplayFullScreen = False
Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="13021429"
    With ActiveSheet
        lr = .Range("B" & Rows.Count).End(xlUp).row
        .PageSetup.PrintArea = "B2:K" & lr
        '.PrintOut
        .PrintPreview
    End With
    ActiveSheet.Protect Password:="13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    Application.EnableEvents = True
    Application.DisplayFullScreen = True
End Sub
Sub HideStuff()

Application.DisplayFullScreen = True
Application.DisplayFormulaBar = False
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayGridlines = False
End Sub
Sub ShowStuff()

Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayGridlines = True
End Sub
Sub ProtectAllCells()
  ' Face lock la toate celulele din activesheet
  ' Suprima selectarea
     Dim sh As Worksheet
On Error Resume Next
For Each sh In ActiveWorkbook.Sheets
    sh.Unprotect "13021429"
    Application.CutCopyMode = False
    sh.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True
    sh.EnableSelection = xlNoSelection
Next sh

End Sub
Sub UnprotectAllCells()
    Dim sh As Worksheet
On Error Resume Next
For Each sh In ActiveWorkbook.Sheets
    sh.Unprotect "13021429"
    Application.CutCopyMode = True
    sh.Protect "13021429", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingRows:=True
    sh.EnableSelection = xlUnlockedCells
Next sh

End Sub

Ofertă irepetabilă!

1200 de lecţii video
Microsoft Office

ITLearning/Dr.Excel