Новости:

Название темы должно отражать суть задачи.
Темы типа "ПОМОГИТЕ!!!", "Срочно!" и т.п. будут удаляться без объяснения причин

Главное меню

Дописать код, чтобы назначить управление строками и столбцами

Автор axlnik, 30.03.2021, 14:32:05

« назад - далее »

axlnik

Добрый день, взял код вот отсюда: https://www.excel-vba.ru/chto-umeet-excel/kazhdomu-polzovatelyu-svoj-listdiapazon/
пример: Tips_Macro_UsersRulesOnStart.xls (ПРАКТИЧЕСКИЙ ПРИМЕР С ИСПОЛЬЗОВАНИЕМ АДМИНИСТРАТОРА), нужно добавить код который позволит назначать пользователям состоящих в группе "user" строки или колонки как в примере Tips_Macro_Sheets_Hide_Rng_for_Users.xls (ДОСТУП К ОПРЕДЕЛЕННЫМ ЛИСТАМ И СКРЫТИЕ УКАЗАННЫХ СТРОК/СТОЛБЦОВ ) расположенный на той же странице. Мне удобно будет, если для этого будет использоваться [E] столбец
'---------------------------------------------------------------------------------------
' Module    : frmIndicateUser
' DateTime  : 11.05.2012 22:08
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : http://www.excel-vba.ru/chto-umeet-excel/kazhdomu-polzovatelyu-svoj-listdiapazon/
'---------------------------------------------------------------------------------------
Option Explicit

Private Sub cmndbCancel_Click()
    Unload Me
'    ThisWorkbook.Close
End Sub

Private Sub cmndbOK_Click()
    Dim rFndRng As Range
    Dim avItems
    Dim lr As Long, li As Long
    Dim oSheet As Worksheet
    Dim sUserRange As String, sUserSheet As String, sSheets, s As String, ss As String
    Dim sGroupe As String
    Dim bShVis As Boolean

    Application.ScreenUpdating = 0
    With ThisWorkbook.Sheets(sUsersSH)
        li = .Cells(.Rows.Count, 1).End(xlUp).Row
        avItems = .Range(.Cells(2, 1), .Cells(li, 4)).Value
    End With
    If cmbUsers <> "" Then
        For lr = 1 To UBound(avItems, 1)
            s = LCase(avItems(lr, 1))
            sGroupe = avItems(lr, 4)
            If Len(s) Then
                If s = LCase(Me.cmbUsers.Value) Then
                    ss = avItems(lr, 2)
                    If Me.txtbKod = ss Then
                        'АДМИН
                        If sGroupe = "admin" Then
                            For Each oSheet In ThisWorkbook.Sheets
                                oSheet.Visible = -1
                            Next
                        Else
                            'ПОЛЬЗОВАТЕЛЬ
                            sUserSheet = avItems(lr, 3)
                            sSheets = Split(sUserSheet, ";")
                            For Each oSheet In ThisWorkbook.Sheets
                                If oSheet.Name <> sMainSheet Then oSheet.Visible = 2
                            Next
                            For Each oSheet In ThisWorkbook.Sheets
                                If oSheet.Name <> sUsersSH Then
                                    For li = 0 To UBound(sSheets)
                                        If oSheet.Name = sSheets(li) Then
                                            Sheets(sSheets(li)).Visible = -1
                                            bShVis = True
                                        End If
                                    Next li
                                End If
                            Next
                            If bShVis Then
                                Sheets(sSheets(0)).Activate
                                Sheets(sMainSheet).Visible = 2
                            Else
                                MsgBox "Для указанного пользователя нет листов для работы!", vbCritical, "Ошибка": Exit Sub
                            End If
                        End If
                    Else
                        MsgBox "Неверно указан код!", vbCritical, "Ошибка": Exit Sub
                    End If
                    Exit For
                End If
            End If
        Next lr
    Else
        MsgBox "Необходимо указать пользователя!", vbCritical, "Нет данных": Exit Sub
    End If

    bClose = False
    Application.ScreenUpdating = 1
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim li As Long
    With ThisWorkbook.Sheets(sUsersSH)
        For li = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            cmbUsers.AddItem .Cells(li, 1)
        Next li
    End With
    bClose = True
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If bClose = True Then ThisWorkbook.Close True
End Sub

Яндекс.Метрика Рейтинг@Mail.ru