Скрытые ячейки по условию

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Скрытые ячейки по условию (Макросы/Sub)

ekut

Дата: Вторник, 16.08.2022, 10:29 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

Уважаемые Екселисты! Если не трудно, помогите!!! Необходимо скрыть листы, кроме Список, Сальдо и Перечень, с возможностью сохранять их без формул. В списке с помощью галочки я сохраняю листы без формул. А скрытые листы без формул сохранить не могу!!! Благодарю заранее

К сообщению приложен файл: __.rar (461.9 Kb)

Ответить

msi2102

Дата: Вторник, 16.08.2022, 11:05 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 415

Репутация: 129 ±

Замечаний: 0% ±

Excel 2007

Попробуйте так
[vba]

Код

Sub SaveList()
    Dim Wsh As Worksheet, shSpis As Worksheet
    Dim iPath  As String
    Dim cell As Range, cellls As Range
    Set shSpis = ThisWorkbook.Worksheets("Список")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    iPath = ThisWorkbook.Path & "\Списание ТМЦ уч.св.№5\"            '
    'проверяем есть ли такая папка, если нет, то создаем
    If Dir(iPath, vbDirectory) = "" Then MkDir iPath
    rrow = shSpis.Cells(Rows.Count, 1).End(xlUp).Row
'=====================================================================================================
    i = 0 ' флаг скрыт или нет лист
'=====================================================================================================
    For t = 2 To rrow
        For Each Wsh In Worksheets      'цикл по листам, кроме Список
            If Wsh.Name <> "Список" Then
                If shSpis.Range("A" & t) = "a" And shSpis.Range("b" & t) = Wsh.Name Then
'=====================================================================================================
                If Wsh.Visible = False Then i = 1: Wsh.Visible = True ' проверка скрыт лист или нет, если скрат, по показать
'=====================================================================================================
                    Wsh.Copy    'копируем очередной лист
                    ActiveSheet.UsedRange.Copy
                    ActiveSheet.UsedRange.PasteSpecial xlValues
                    ActiveWorkbook.Close SaveChanges:=True
'=====================================================================================================
                    If i = 1 Then i = 0: Wsh.Visible = False ' проверка если лист был скрыт то скрывает его
'=====================================================================================================
                End If
            End If
        Next
    Next
    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

[/vba]

Попробуйте так
[vba]

Код

[/vba]msi2102

Ответить

СообщениеПопробуйте так
[vba]

Код

[/vba]

Автор - msi2102
Дата добавления - 16.08.2022 в 11:05

ekut

Дата: Вторник, 16.08.2022, 11:31 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

Спасибо за быстрый ответ! Только проблема в том, что изначально сохраненные листы без формул сохранялись в указанную папку в макросе автоматически и с названием листа! А сейчас Книгой 1 и 2.

Ответить

msi2102

Дата: Вторник, 16.08.2022, 11:35 | Сообщение № 4

Группа: Проверенные

Ранг: Обитатель

Сообщений: 415

Репутация: 129 ±

Замечаний: 0% ±

Excel 2007

Прошу прощения, это я удалил лишнюю строку
[vba]

Код

Sub SaveList()
    Dim Wsh As Worksheet, shSpis As Worksheet
    Dim iPath  As String
    Dim cell As Range, cellls As Range
    Set shSpis = ThisWorkbook.Worksheets("Список")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    iPath = ThisWorkbook.Path & "\Списание ТМЦ уч.св.№5\"            '
    'проверяем есть ли такая папка, если нет, то создаем
    If Dir(iPath, vbDirectory) = "" Then MkDir iPath
    rrow = shSpis.Cells(Rows.Count, 1).End(xlUp).Row
'=====================================================================================================
    i = 0 ' флаг скрыт или нет лист
'=====================================================================================================
    For t = 2 To rrow
        For Each Wsh In Worksheets      'цикл по листам, кроме Список
            If Wsh.Name <> "Список" Then
                If shSpis.Range("A" & t) = "a" And shSpis.Range("b" & t) = Wsh.Name Then
'=====================================================================================================
                If Wsh.Visible = False Then i = 1: Wsh.Visible = True ' проверка скрыт лист или нет, если скрат, по показать
'=====================================================================================================
                    Wsh.Copy    'копируем очередной лист
                    ActiveSheet.UsedRange.Copy
                    ActiveSheet.UsedRange.PasteSpecial xlValues
                    ActiveWorkbook.SaveAs iPath & Wsh.Name & ".xlsx"    'в подпапку СИЗ уч.св.№5
                    ActiveWorkbook.Close SaveChanges:=True
'=====================================================================================================
                    If i = 1 Then i = 0: Wsh.Visible = False ' проверка если лист был скрыт то скрывает его
'=====================================================================================================
                End If
            End If
        Next
    Next
    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

[/vba]

Прошу прощения, это я удалил лишнюю строку
[vba]

Код

Sub SaveList()
    Dim Wsh As Worksheet, shSpis As Worksheet
    Dim iPath  As String
    Dim cell As Range, cellls As Range
    Set shSpis = ThisWorkbook.Worksheets("Список")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    iPath = ThisWorkbook.Path & "\Списание ТМЦ уч.св.№5\"            '
    'проверяем есть ли такая папка, если нет, то создаем
    If Dir(iPath, vbDirectory) = "" Then MkDir iPath
    rrow = shSpis.Cells(Rows.Count, 1).End(xlUp).Row
'=====================================================================================================
    i = 0 ' флаг скрыт или нет лист
'=====================================================================================================
    For t = 2 To rrow
        For Each Wsh In Worksheets      'цикл по листам, кроме Список
            If Wsh.Name <> "Список" Then
                If shSpis.Range("A" & t) = "a" And shSpis.Range("b" & t) = Wsh.Name Then
'=====================================================================================================
                If Wsh.Visible = False Then i = 1: Wsh.Visible = True ' проверка скрыт лист или нет, если скрат, по показать
'=====================================================================================================
                    Wsh.Copy    'копируем очередной лист
                    ActiveSheet.UsedRange.Copy
                    ActiveSheet.UsedRange.PasteSpecial xlValues
                    ActiveWorkbook.SaveAs iPath & Wsh.Name & ".xlsx"    'в подпапку СИЗ уч.св.№5
                    ActiveWorkbook.Close SaveChanges:=True
'=====================================================================================================
                    If i = 1 Then i = 0: Wsh.Visible = False ' проверка если лист был скрыт то скрывает его
'=====================================================================================================
                End If
            End If
        Next
    Next
    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

[/vba]msi2102

Сообщение отредактировал msi2102 - Вторник, 16.08.2022, 11:36

Ответить

СообщениеПрошу прощения, это я удалил лишнюю строку
[vba]

Код

Sub SaveList()
    Dim Wsh As Worksheet, shSpis As Worksheet
    Dim iPath  As String
    Dim cell As Range, cellls As Range
    Set shSpis = ThisWorkbook.Worksheets("Список")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    iPath = ThisWorkbook.Path & "\Списание ТМЦ уч.св.№5\"            '
    'проверяем есть ли такая папка, если нет, то создаем
    If Dir(iPath, vbDirectory) = "" Then MkDir iPath
    rrow = shSpis.Cells(Rows.Count, 1).End(xlUp).Row
'=====================================================================================================
    i = 0 ' флаг скрыт или нет лист
'=====================================================================================================
    For t = 2 To rrow
        For Each Wsh In Worksheets      'цикл по листам, кроме Список
            If Wsh.Name <> "Список" Then
                If shSpis.Range("A" & t) = "a" And shSpis.Range("b" & t) = Wsh.Name Then
'=====================================================================================================
                If Wsh.Visible = False Then i = 1: Wsh.Visible = True ' проверка скрыт лист или нет, если скрат, по показать
'=====================================================================================================
                    Wsh.Copy    'копируем очередной лист
                    ActiveSheet.UsedRange.Copy
                    ActiveSheet.UsedRange.PasteSpecial xlValues
                    ActiveWorkbook.SaveAs iPath & Wsh.Name & ".xlsx"    'в подпапку СИЗ уч.св.№5
                    ActiveWorkbook.Close SaveChanges:=True
'=====================================================================================================
                    If i = 1 Then i = 0: Wsh.Visible = False ' проверка если лист был скрыт то скрывает его
'=====================================================================================================
                End If
            End If
        Next
    Next
    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

[/vba]

Автор - msi2102
Дата добавления - 16.08.2022 в 11:35

ekut

Дата: Вторник, 16.08.2022, 12:51 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

Огромноеееее спасибоооо!!!!

Ответить

Скрытые ячейки по условию (Макросы/Sub)

Страница 1 из 1
1