Надстройка для работы с ячейками и листами

Public ОписаниеГорячихКлавиш As String
 
Function НазначитьКомбинацию(ByVal code As String, ByVal macroname As String) As String
    Application.OnKey code, macroname
    Клавиша = UCase(code)
    Клавиша = Replace(Клавиша, "+", "Shift + ")
    Клавиша = Replace(Клавиша, "^", "Ctrl + ")
    Клавиша = Replace(Клавиша, "%", "Alt + ")
    Клавиша = Клавиша & Space(36 - Len(Клавиша))
    НазначитьКомбинацию = "Клавиша: " & vbTab & Клавиша & vbTab & "Макрос: " & vbTab & macroname & vbNewLine
End Function

Sub КоличествоЛистовВКниге()
    If ActiveWorkbook Is Nothing Then MsgBox "Сначала откройте книгу, а потом запускайте макрос", vbCritical, "Ошибка": End
    Dim sh As Worksheet, msg As String
    msg = "Книга: " & ActiveWorkbook.Name & vbNewLine
    msg = msg & "Путь: " & ActiveWorkbook.Path & vbNewLine & vbNewLine
    msg = msg & "Количество листов: " & ActiveWorkbook.Worksheets.Count & vbNewLine & vbNewLine
 
    For Each sh In ActiveWorkbook.Worksheets
        msg = msg & "Лист " & sh.Index & ": " & vbTab & _
              " (" & sh.UsedRange.Rows.Count & " строк)" & vbTab & sh.Name & vbNewLine
    Next sh
    MsgBox msg, vbInformation, "Информация о текущей книге"
End Sub

Sub ДобавлениеФразыКИменамВыделенныхЛистов()
    Dim sh As Worksheet, Фраза As String: On Error Resume Next
    ЗапрещённыеСимволы = "\/?:*[]": ЗапрещённыеСимволы2 = "\ / ? : * [ ] "
    msg = "Введите фразу для добавления к именам выделенных листов" & vbNewLine & vbNewLine
    msg = msg & "Выделено листов:  " & ActiveWindow.SelectedSheets.Count & vbNewLine & vbNewLine
    msg = msg & "Запрещено использовать символы:  " & ЗапрещённыеСимволы2 & vbNewLine
    msg = msg & "Максимальная длина имени листа - 31 символ"
    Фраза = InputBox(msg, "Переименование листов - Бонус :)", "- проверен")
 
    For i = 1 To Len(ЗапрещённыеСимволы)
        символ = Mid(ЗапрещённыеСимволы, i, 1)
        Фраза = Replace(Фраза, символ, "")
    Next
 
    For Each sh In ActiveWindow.SelectedSheets
        НовоеИмяЛиста = sh.Name & " " & Trim(Фраза)
        sh.Name = Left(НовоеИмяЛиста, 31)
        sh.Tab.Color = vbYellow
    Next sh
End Sub

Sub ВывестиОписаниеГорячихКлавиш()
    MsgBox ОписаниеГорячихКлавиш, vbInformation, "Список ""горячих клавиш"""
End Sub

Sub ОкраскаОбъединённыхЯчеек()
    On Error Resume Next
    Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        Set ra = sh.Cells.SpecialCells(xlCellTypeConstants)
        For Each cell In ra.Cells
            If cell.MergeCells Then cell.Interior.Color = vbRed
        Next cell
    Next sh
    Application.ScreenUpdating = True
End Sub

Sub ОкраскаВсехОбъединённыхЯчеек()
    On Error Resume Next
    Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        Set ra = sh.UsedRange
        For Each cell In ra.Cells
            If cell.MergeCells Then cell.Interior.Color = vbRed
        Next cell
    Next sh
    Application.ScreenUpdating = True
End Sub

Sub ОбъединениеЗначенийИзЯчеек()
    ОбработкаЯчеек True
End Sub
 
Sub РазъединениеЗначенийИзЯчеек()
    ОбработкаЯчеек False
End Sub
 
Sub ОбработкаЯчеек(ByVal объединение As Boolean)
    On Error Resume Next
    Dim sh As Worksheet: Set sh = ActiveSheet
    If sh Is Nothing Then MsgBox "Сначала откройте нужную книгу, а потом запускайте макрос!", vbExclamation: Exit Sub
    Dim ВыделеныСтроки As Boolean
 
    Select Case Selection.Address
        Case Cells.Address: MsgBox "Вы выделили весь лист. Так делать нельзя :) Выделите диапазон поменьше.", vbExclamation: Exit Sub
        Case Selection.EntireRow.Address: ВыделеныСтроки = True    ' MsgBox "rows"
        Case Selection.EntireColumn.Address: ВыделеныСтроки = False:    'MsgBox "columns"
        Case Else: ' MsgBox "Вы выделили диапазон ячеек, не являющийся ни строками, ни столбцами. Выделите либо строки, либо столбцы.", vbExclamation: Exit Sub
    End Select
 
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Set ra = Selection 'Intersect(Selection, sh.UsedRange)
    If ra Is Nothing Then MsgBox "В выделенном диапазоне отсутствуют данные.", vbExclamation: Exit Sub
    Dim cel As Range
 
    For Each cell In ra.Rows
 
        If объединение Then
            res = ""
            For Each cel In cell.Cells
                ct = cel.Text: If Len(Trim(ct)) Then res = res & Разделитель & ct
            Next cel
            res = Trim(res)
            If Len(res) Then cell.ClearContents: cell.Cells(1) = res
        Else
            cv = Application.Trim(cell.Cells(1)): arr = Split(cv, Разделитель)
            For i = LBound(arr) To UBound(arr)
                cell.Cells(1)(1, i + 1) = arr(i)
            Next i
        End If
    Next cell
    Application.ScreenUpdating = True
End Sub

Sub ПоискДубликатовВКниге()
    Dim sh As Worksheet, coll As New Collection, delra As Range
    On Error Resume Next
    msg = "Поиск дубликатов в книге " & ActiveWorkbook.Name & vbNewLine & vbNewLine
    ДиапазонСравнения = СтолбцыДляОбработки
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        Set delra = Nothing
        Dim cell As Range, ra As Range
        For Each cell In sh.UsedRange.Rows
            txt = ТекстСтроки(cell, ДиапазонСравнения): Err.Clear
            If Len(txt) Then
                coll.Add txt, txt
                If Err Then If delra Is Nothing Then Set delra = cell Else Set delra = Union(delra, cell)
            End If
        Next cell
        msg = msg & "На листе """ & sh.Name & """" & Space(32 - Len(sh.Name)) & vbTab & "  удалено " & delra.Rows.Count & " строк" & vbNewLine
        delra.EntireRow.Delete    'delra.Interior.ColorIndex = 33
    Next sh
    msg = msg & vbNewLine & "Поиск дубликатов в книге " & ActiveWorkbook.Name & " завершён"
    Application.ScreenUpdating = True
    MsgBox msg, vbInformation, "Готово"
End Sub

Function ТекстСтроки(ByRef ra As Range, ByVal txt As String) As String
    Dim cell As Range
    For Each cell In Intersect(ra.EntireRow, ra.Worksheet.Range(txt))
        ТекстСтроки = ТекстСтроки & Trim(cell)
    Next cell
End Function
 
Function СтолбцыДляОбработки() As String
    On Error Resume Next: res = "": СтолбцыДляОбработки = "$a:$f"    'Selection.EntireColumn.Address(0, 0)
    msg = "Выберите диапазон, на основании которого будет производиться сравнение строк" & vbNewLine & vbNewLine
    msg = msg & "Не обязательно выделять столбцы целиком - достаточно выделить по одной ячейке в столбцах" & vbNewLine
    'msg = msg & "Для выделения несмежных диапазонов удерживайте клавишу Ctrl" & vbNewLine
    Set a = Application.InputBox(msg, "Выделите сравниваемые столбцы", СтолбцыДляОбработки, , , , , 8)
    res = a.EntireColumn.Address(False, False)
    If res <> "" Then СтолбцыДляОбработки = res Else СтолбцыДляОбработки = "a:f"
End Function

Sub РаскидатьЛистыПоФайлам()
    On Error Resume Next: X = ActiveSheet.[e5]
    If Err.Number Then MsgBox "Сначала откройте нужную книгу, а потом запускайте макрос!", vbExclamation: Exit Sub
    If ActiveWorkbook.Path = "" Then MsgBox "Сначала сохраните книгу, а потом запускайте макрос!", vbExclamation: Exit Sub
 
    ПапкаДляФайлов = СозданиеПапкиДляФайловСозданныхИзЛистов: n = 0
    ИмяФайла = Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name & ".", ".") - 1)
    Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
    MkDir ПапкаДляФайлов
 
    defCALC = Application.Calculation: Application.DisplayAlerts = False
    Application.EnableEvents = False: Application.Calculation = xlCalculationManual
    Dim pi As New ProgressIndicator
    pi.Show "Создание файлов из листов..."
    pi.StartNewAction 0, 100, "Создание файлов..."
    pi.CurActionCount = ActiveWorkbook.Worksheets.Count: i = 1
 
    For Each sh In ActiveWorkbook.Worksheets
        If Not sh.Name Like ИмяЛистаСОглавлением & "*" Then
            pi.CurAction 0, 0, "Сохранение листа  """ & sh.Name & """...  ", _
                         "(лист " & i & " из " & ActiveWorkbook.Worksheets.Count & ")": i = i + 1
            Err.Clear:
            sh.Copy
            ActiveWorkbook.SaveAs ПапкаДляФайлов & "\" & sh.Name
            If Err.Number = 0 Then n = n + 1 Else НекорректныеЛисты = НекорректныеЛисты & sh.Name & vbNewLine
            ActiveWorkbook.Close False
        Else
            n = n + 1
        End If
    Next sh
 
    Application.EnableEvents = True: Application.Calculation = defCALC: Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    pi.Hide
    If n > 0 Then
        msg = IIf(ActiveWorkbook.Worksheets.Count = n, _
                  "Создано " & n & " файлов Excel в папке " & _
                  vbNewLine & vbNewLine & ПапкаДляФайлов, _
                  "Создано только " & n & " файлов Excel из " & _
                  ActiveWorkbook.Worksheets.Count & " листов  в папке " _
                  & vbNewLine & vbNewLine & ПапкаДляФайлов & vbNewLine & vbNewLine & _
                  "Не удалось создать файлы для листов с именами:" & vbNewLine & НекорректныеЛисты)
        MsgBox msg, _
               IIf(ActiveWorkbook.Worksheets.Count = n, vbInformation, vbExclamation), "Готово"
        CreateObject("wscript.shell").Run Chr(34) & ПапкаДляФайлов & Chr(34)
    Else
        MsgBox "Файлы не были созданы!", vbExclamation, "Готово"
    End If
 
End Sub

Function СозданиеПапкиДляФайловСозданныхИзЛистов() As String
    ТекущаяПапка = CreateObject("scripting.filesystemobject").getfolder(ActiveWorkbook.Path).Name
    ИмяФайла = Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name & ".", ".") - 1)
 
    ИмяПапки = Trim(ИмяФайла) & " - отдельные листы"
    On Error Resume Next
    путь = Replace(ActiveWorkbook.FullName, ActiveWorkbook.Name, ИмяПапки)
    If Dir(путь, vbDirectory) <> "" Then _
       Name путь As Replace(путь, ИмяПапки, "Архив файлов Excel от " & Format(Now, "YYYY-MM-DD__HH-NN-SS"))
    MkDir путь
    If Dir(путь, vbDirectory) <> "" Then СозданиеПапкиДляФайловСозданныхИзЛистов = путь _
       Else MsgBox "Не удалось создать папку" & vbNewLine & vbNewLine & путь, vbCritical, "Ошибка"
End Function

Option Compare Text
Public Const ИмяЛистаСОглавлением = " Оглавление"
 
Sub ОбъединениеФайловИзВыбраннойПапки()
    On Error Resume Next
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")
    Dim coll As New Collection: Application.ScreenUpdating = False: Application.DisplayAlerts = False
 
    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов Excel", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub
 
    DestinationWB = SourceFolder & "Объединённый" & IIf(Val(Application.Version) >= 12, ".xlsb", ".xls")
    Workbooks(DestinationWB).Close False
    If Len(Dir(DestinationWB)) Then Kill DestinationWB
 
    filename = Dir(SourceFolder & IIf(Val(Application.Version) >= 12, "*.xls*", "*.xls"))
    While filename <> ""
        coll.Add SourceFolder & filename: filename = Dir
    Wend
    If coll.Count = 0 Then MsgBox "Файлы для обработки не найдены", vbExclamation, "Выберите другую папку": Exit Sub
 
    Dim pi As New ProgressIndicator
    pi.Show "Объединение нескольких книг Excel в один файл"
    pi.StartNewAction 0, 5, "Создание итогового файла..."
 
 
    Dim destWB As Workbook, sh As Worksheet: Set destWB = Workbooks.Add(xlWBATWorksheet)
    destWB.Worksheets(1).Name = ИмяЛистаСОглавлением
 
    defCALC = Application.Calculation
    Application.EnableEvents = False: Application.Calculation = xlCalculationManual
 
    pi.StartNewAction 5, 90, "Обработка файлов...": pi.CurActionCount = coll.Count: i = 1
 
    For Each filename In coll
        DoEvents
        pi.line1 = "Обработка файлов ...  (файл " & i & " из " & coll.Count & ")": i = i + 1
        ОбработкаФайла filename, destWB, pi
    Next
    SortSheets destWB
    СозданиеОглавления destWB
 
    ФорматИтоговогоФайла = IIf(Val(Application.Version) >= 12, 50, -4143)    ' xlExcel12  или  xlWorkbookNormal
    pi.StartNewAction 90, 100, "Сохранение итогового файла...", "Имя файла:  " & "Объединённый" & IIf(Val(Application.Version) >= 12, ".xlsb", ".xls")
 
    destWB.SaveAs DestinationWB, ФорматИтоговогоФайла
 
    pi.Hide
    Application.EnableEvents = True: Application.Calculation = defCALC: Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub ОбработкаФайла(ByVal filename As String, ByRef destWB As Workbook, ByRef pi As ProgressIndicator)
    Dim wb As Workbook, sh As Worksheet: On Error Resume Next
    pi.CurAction 0, 0, , "Обрабатывается файл:  " & Dir(filename)
    If Val(Application.Version) < 12 And Right(filename, 4) <> ".xls" Then Exit Sub
    Set wb = Workbooks.Open(filename, False, True)
 
    For Each sh In wb.Worksheets
        DoEvents
        If Not sh.Name Like ИмяЛистаСОглавлением & "*" Then
            Err.Clear: sh.UsedRange.Value = sh.UsedRange.Value
            If Err Then
                sh.UsedRange.Copy: sh.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = 0
                Debug.Print "Ошибка в книге ", wb.Name, "на листе", sh.Name
            End If
            sh.Copy , destWB.Worksheets(destWB.Worksheets.Count)
        End If
    Next sh
    wb.Close False
    Set wb = Nothing
End Sub

Sub СозданиеОглавления(ByRef wb As Workbook)
    Dim sheet As Worksheet, cell As Range: On Error Resume Next
    With wb
        Dim sh As Worksheet: Set sh = .Worksheets(1)
        For Each sheet In .Worksheets
            If sh.Name <> sheet.Name Then
                Set cell = .Worksheets(1).Cells(sheet.Index, 1)
                .Worksheets(1).Hyperlinks.Add cell, "", "'" & sheet.Name & "'" & "!A1", , sheet.Name
            End If
        Next
        sh.Cells(1) = "Перечень листов:": sh.Tab.Color = vbGreen
        sh.Columns(1).AutoFit: .Activate: sh.Activate: [a2].Select: ActiveWindow.FreezePanes = True
    End With
End Sub

Sub SortSheets(ByRef wb As Workbook)
    Dim i As Integer, j As Integer: On Error Resume Next
    With wb
        For i = 1 To .Worksheets.Count - 1
            For j = i + 1 To .Worksheets.Count
                If UCase(.Worksheets(i).Name) > UCase(.Worksheets(j).Name) Then .Worksheets(j).Move Before:=.Worksheets(i)
            Next j
        Next i
    End With
End Sub
 
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

Public Const Разделитель = " "
 
Function СозданиеПапкиДляВременныхФайлов() As String
    ТекущаяПапка = CreateObject("scripting.filesystemobject").getfolder(ActiveWorkbook.Path).Name
    ИмяФайла = Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name & ".", ".") - 1)
 
    ИмяПапки = Trim(ИмяФайла) & " TXT"
    On Error Resume Next
    путь = Replace(ActiveWorkbook.FullName, ActiveWorkbook.Name, ИмяПапки)
    If Dir(путь, vbDirectory) <> "" Then _
       Name путь As Replace(путь, ИмяПапки, "Архив текстовых файлов от " & Format(Now, "YYYY-MM-DD__HH-NN-SS"))
    MkDir путь
    If Dir(путь, vbDirectory) <> "" Then СозданиеПапкиДляВременныхФайлов = путь _
       Else MsgBox "Не удалось создать папку" & vbNewLine & vbNewLine & путь, vbCritical, "Ошибка"
End Function

Sub СозданиеТекстовыхФайлов()
    On Error Resume Next: X = ActiveSheet.[e5]
    If Err.Number Then MsgBox "Сначала откройте нужную книгу, а потом запускайте макрос!", vbExclamation: Exit Sub
    If ActiveWorkbook.Path = "" Then MsgBox "Сначала сохраните книгу, а потом запускайте макрос!", vbExclamation: Exit Sub
 
    ПапкаДляТекстовыхФайлов = СозданиеПапкиДляВременныхФайлов: n = 0
    ИмяФайла = Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name & ".", ".") - 1)
    Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
 
    For Each sh In ActiveWorkbook.Worksheets
        ПапкаДляФайловЛиста = ПапкаДляТекстовыхФайлов & "\" & sh.Name
        MkDir ПапкаДляФайловЛиста
 
        Заголовок = ТекстДиапазона(sh.[1:1]) & vbNewLine & ТекстДиапазона(sh.[2:2]) & vbNewLine _
                    & ТекстДиапазона(sh.[3:3]) & vbNewLine & ТекстДиапазона(sh.[4:4]) & vbNewLine _
                    & ТекстДиапазона(sh.[5:5]) & vbNewLine
        For i = 1 To 5: Заголовок = Replace(Заголовок, vbNewLine & vbNewLine, ""): Next
        If Заголовок Like vbNewLine & "*" Then Заголовок = Mid(Заголовок, 3)
 
        Set ra = Intersect(sh.UsedRange, sh.Range("6:" & Rows.Count))
        For Each cell In ra.Rows
            If IsNull(cell.EntireRow.Text) Then
                txt = ТекстДиапазона(cell)
                If Len(txt) Then
                    n = n + 1
                    СохранитьТекстовыйФайл _
                            Заголовок & txt, ПапкаДляФайловЛиста & _
                                             "\" & ИмяФайла & " + " & sh.Name & _
                                             " + " & "Данные из строки " & cell.Row & ".txt"
                End If
            End If
        Next cell
    Next sh
 
    Application.ScreenUpdating = True
    If n > 0 Then
        MsgBox "Создано " & n & " текстовых файлов в папке " _
               & vbNewLine & vbNewLine & ПапкаДляТекстовыхФайлов, vbInformation, "Готово"
        CreateObject("wscript.shell").Run Chr(34) & ПапкаДляТекстовыхФайлов & Chr(34)
    Else
        MsgBox "Файлы не были созданы!", vbExclamation, "Готово"
    End If
End Sub

Function ТекстДиапазона(ByRef ra As Range) As String
    On Error Resume Next
    For Each cell In Intersect(ra, ra.Worksheet.UsedRange)
        ТекстДиапазона = ТекстДиапазона & Разделитель & cell
    Next cell
    ТекстДиапазона = WorksheetFunction.Trim(ТекстДиапазона)
    ТекстДиапазона = Replace(ТекстДиапазона, vbLf, " ")
End Function
 
Sub СохранитьТекстовыйФайл(ByVal txt As String, ByVal filename As String)
    On Error Resume Next: Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write txt: ts.Close: Set ts = nothinh: Set fso = Nothing
End Sub