Клавиша: | Ctrl + T | Макрос: | Создание Текстовых Файлов |
Клавиша: | Ctrl + 4 | Макрос: | Окраска Объединённых Ячеек |
Клавиша: | Ctrl + 5 | Макрос: | Окраска Всех Объединённых Ячеек |
Клавиша: | Ctrl + G | Макрос: | Объединение Значений Из Ячеек |
Клавиша: | Ctrl + Shift + G | Макрос: | Разъединение Значений Из Ячеек |
Клавиша: | Ctrl + Shift + D | Макрос: | Поиск Дубликатов В Книге |
Клавиша: | Ctrl + Shift + O | Макрос: | Объединение Файлов Из Выбранной Папки |
Клавиша: | Ctrl + Shift + E | Макрос: | Раскидать Листы По Файлам |
Клавиша: | Ctrl + L | Макрос: | Количество Листов В Книге |
Клавиша: | Ctrl + Shift + L | Макрос: | Добавление Фразы К Именам Выделенных Листов |
Код надстройки:
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
Комментарии
Отправить комментарий