Страницы: 1
RSS
Разделить таблицу на файлы
 
Подскажите, возможно ли разделить сводную на файлы по названию столбца с названием файлов по этому же столбцу, с сохранением формул в ячейках ([Цена]*[Количество]) и сохранить форматирование ячеек + защиту книги паролем?
 
легко
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, я бы попросил реализовать, могу оплатить, если это трудоёмкая задача  
 
рано говорить об оплатить
для начало нужно увидеть материал (файл с которым нужно будет работать) и из ваших обьяснений понять что с ним нужно делать
понимаете, задача разобрать файл по колнках - это очень приблизительная задача
написанный по такому ТЗ макрос скорее всего будет генерировать всякую ерунду, совершенно вам не нужную
чтобы получить результат нужен материал и описание задачи
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Артур Горохов написал:
могу оплатить
Перенести тему в платный раздел?
 
Ігор Гончаренко, тут первые 1000 строк.
Задача:
Разделить на файлы по столбцу "Отделение". Название файлов из того же столбца
Сохранить формат умной таблицы со строкой итогов по 4 столбцам: Количество 2021, Итого 2021, Количество 2022, Итого 2022.
Сохранить форматы ячеек и формулу для расчета Итого 2022.
Защитить листы в файлах с паролем 2106.
Оставить для пользователя возможность автофильтра и сортировки. Оставить доступными для заполнения столбец Итого 2022, ОМС, ВМП, ПМУ и сохранить цветовой стиль ячеек и формат (целое число).
 
Артур Горохов, если никто не поможет, готов платно написать вам макрос. Будет всё работать, кроме возможности Сортировки на защищённом листе.
Договорились с автором, отправил ему макрос
Изменено: New - 21.06.2022 22:34:27
 
New, раз ветка бесплатная то может покажете Всем?
 
Не знаю, как насчёт файлов, а на листы, думаю, можно попробовать через функцию "Страницы полей фильтра сводной таблицы" (или полей среза, не помню по памяти). А уж раскидать листы по файлам труда не составит. "Я так думаю!" (с)
 
Тимофеев,
Код
Sub Split_Table_To_Files()
    Dim arrData, Dict As Object, i As Long, LO As ListObject, wsSheetData As Worksheet
    Dim sDepartment As String, vKey As Variant, lCounter As Long, Rng As Range
    
    If MsgBox("Split the table into separate files by departments?", vbQuestion + vbYesNo, "Question") = vbNo Then Exit Sub
    
    Set wsSheetData = ActiveSheet
    On Error Resume Next
    Set LO = wsSheetData.ListObjects("Table1")
    On Error GoTo 0
    
    If LO Is Nothing Then
        MsgBox "There is no 'Table1' on the active sheet!", vbExclamation, "Error"
        Exit Sub
    End If
    
    LO.AutoFilter.ShowAllData
    arrData = LO.Range.Value
    
    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = 2 To UBound(arrData)
        sDepartment = arrData(i, 1)
        If sDepartment <> "Total" Then
            If Not Dict.Exists(sDepartment) Then Dict(sDepartment) = 0&
        End If
    Next i
    
    If Dict.Count = 0 Then
        MsgBox "It was not possible to collect the unique names of the departments!", vbExclamation, "Error"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo errHandler:
     
    For Each vKey In Dict.Keys
        ActiveSheet.Copy
        Set LO = ActiveSheet.ListObjects(1)
        With LO
            .AutoFilter.ShowAllData
            .Range.AutoFilter Field:=1, Criteria1:="<>" & vKey
            '-2 - это оставляем строку Итогов
            Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 2, .AutoFilter.Range.Columns.Count).SpecialCells(xlCellTypeVisible)
            Rng.Delete
            .AutoFilter.ShowAllData
        End With
        
        With ActiveSheet
            .Columns(1).ColumnWidth = 40
            .Range("A1").Select
            .Cells.Locked = True
            .Columns("H:H").Locked = False
            .Columns("K:M").Locked = False
            .Protect Password:="2106", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowSorting:=True, AllowFiltering:=True
        End With
        ActiveWindow.LargeScroll Down:=-1000
        If Dir(ThisWorkbook.Path & Application.PathSeparator & vKey & ".xlsx") <> "" Then
            Kill ThisWorkbook.Path & Application.PathSeparator & vKey & ".xlsx"
        End If
        ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & vKey & ".xlsx", xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close (False)
        lCounter = lCounter + 1
    Next vKey
 
errHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Created " & lCounter & " files!", vbInformation, "Finish"
End Sub
Изменено: New - 22.06.2022 13:20:57
Страницы: 1
Наверх