Страницы: 1
RSS
При изменении на главной странице данные отобразить в листах подразделений
 
Есть файл Хочу разбить по подразделениям, если я напишу на главной чтоб обновился и в подразделении.
Изменено: vikttur - 13.09.2021 12:54:45
 
вот сам файл
 
Код
Option Explicit

Sub SaveFiles()
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    Dim wb As Workbook
    Dim s As String
    
    Application.DisplayAlerts = False
    With sh1
        Dim arr As Variant
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
        'If y = 1 Then Exit Sub
        arr = .Range(.Cells(1, 1), .Cells(y, 3))
        
        Dim n As Variant
        Dim e As Variant
        y = 1
        Do
            If y > UBound(arr, 1) Then Exit Do
            e = y
            Do
                If e > UBound(arr, 1) Then Exit Do
                If arr(e, 1) = "N" Then Exit Do
                e = e + 1
            Loop
            e = e + 1
            Do
                If e > UBound(arr, 1) Then Exit Do
                If arr(e, 1) = "N" Then Exit Do
                e = e + 1
            Loop
            e = e - 1
            Do
                If e < LBound(arr, 1) Then Exit Do
                If .Cells(e, 1).Interior.ColorIndex <> -4142 Then Exit Do
                e = e - 1
            Loop
            n = e
            Do
                If n < LBound(arr, 1) Then Exit Do
                If Trim(arr(n, 3)) <> "" Then Exit Do
                n = n - 1
            Loop
            
            Cells(y, 1).Select
            
            '.Range(Cells(y, 1), Cells(e, 1)).EntireRow
            Set wb = Workbooks.Add(1)
            .Copy Before:=wb.Sheets(1)
            wb.Sheets(2).Delete
            
            With wb.Sheets(1)
                If y > 1 Then
                    With .Range(.Cells(1, 1), .Cells(y, 1)).EntireRow
                        .Clear
                        .Hidden = True
                    End With
                End If
                    With .Range(.Cells(e + 1, 1), .Cells(UBound(arr, 1) - 1, 1)).EntireRow
                        .Clear
                        .Hidden = True
                    End With
            End With
            
            s = Trim(arr(n, 3))
            s = s & ".xlsx"
            On Error Resume Next
            Workbooks(s).Close
            On Error GoTo 0
            
            s = .Parent.Path & "\" & s
            If Dir(s) <> "" Then Kill s
            wb.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            wb.Close False
            
            y = e + 1
        Loop
        
    End With
    
    Application.DisplayAlerts = True
End Sub
 
Цитата
МатросНаЗебре написал:
Application.DisplayAlerts = TrueEnd Su
Как это добавить
 
Можно посмотреть тут.
Создание макросов и пользовательских функций на VBA (planetaexcel.ru)
Способа 1, в принципе, достаточно.
 
Извините я этим не занимался.
Изменено: vikttur - 14.09.2021 09:15:48
 
Цитата
alihan95 написал:
Извините я этим не занимался.
Не стоит стесняться. Мы тут все нет-нет и занимаемся этим. Некоторых прям за уши не оттащишь, дай только этим позаниматься. )

Alt+F11
Правый клик на "ЭтаКнига" (это вверху слева).
Insert - Module
В появившееся окно вставляете код с форума.
Возвращаетесь в Excel - клик на любую ячейку.
Alt+F11
Выбрать макрос.
Выполнить.
Изменено: МатросНаЗебре - 14.09.2021 09:15:55
 
МатросНаЗебре, как сделать кнопку
 
Вы в одном гугле от ответа.
Как создать кнопку в Excel (lumpics.ru)
Страницы: 1
Наверх