End If 'копируем фрагмент данных на новый лист Range(tws.Cells(startrow, 1), tws.Cells(i, rngData.Columns.Count)).Copy outws.Range("B1").PasteSpecial , Transpose:=True 'Тестовое Sheets("Тех").Select Range("A1:A44").Select Copy Destination:=outws.Range("A1") 'переносим ширину столбцов Range(tws.Cells(startrow, 1), tws.Cells(i, rngData.Columns.Count)).Copy outws.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths startrow = i + 1 'добавляем шапку, если нужно If chkHeader Then outws.Rows("1:" & hr).Insert Shift:=xlDown tws.Rows("1:" & hr).Copy Destination:=outws.Cells(1, 1) End If End If Next i End If
Private Sub btnCancel_Click() Unload MeEnd SubPrivate Sub btnOK_Click() Dim tws As Worksheet, sourcews As Worksheet, outws As Worksheet Dim startrow As Long, finishrow As Long, i As Long Dim rngData As Range, hr As Integer, intRowStep As Long Dim TableName As String Dim ActiveTable As ListObject 'проверяем заполнение формы ---------------------------------------------------------------------------------------------------------------------------- On Error Resume Next Set rngData = Range(refData) Set sourcews = ActiveSheet hr = CInt(ddHR) 'число строк в шапке nColorCol = CInt(ddColorColumn.Value) 'столбец для разбора по цвету nCol = CInt(ddColumn.Value) 'столбец для разбора по значению intRowsStep = CLng(txtRowsCount.Value) 'число строк в каждом блоке On Error GoTo 0 If IsEmpty(rngData) Then MsgBox "Сначала укажите диапазон с данными для разбора.", vbExclamation, "Ошибка ввода" refData.SetFocus Exit Sub End If If rngData.Areas.Count > 1 Then MsgBox "Выделите только один диапазон, а не несколько.", vbExclamation, "Ошибка ввода" refData.SetFocus Exit Sub End If If hr = 0 Then MsgBox "Введите количество строк в шапке таблицы с данными.", vbExclamation, "Ошибка ввода" ddHR.SetFocus Exit Sub End If If optByColor And nColorCol = 0 Then MsgBox "Задайте номер столбца, по цвету заливки которого пойдет разбор.", vbExclamation, "Ошибка ввода" ddColorColumn.SetFocus Exit Sub End If If optByColumnValues And nCol = 0 Then MsgBox "Задайте номер столбца, по значениям ячеек которого пойдет разбор.", vbExclamation, "Ошибка ввода" ddColumn.SetFocus Exit Sub End If If optByRowsCount And IsEmpty(intRowsStep) Then MsgBox "Укажите шаг деления (количество строк на каждом листе).", vbExclamation, "Ошибка ввода" txtRowsCount.SetFocus Exit Sub End If If optByRowsCount And intRowsStep < 1 Then MsgBox "Шаг деления должен быть целым числом больше нуля.", vbExclamation, "Ошибка ввода" txtRowsCount.SetFocus Exit Sub End If 'если выделены целиком столбцы или строки - урезаем до рабочей области If rngData.Rows.Count = ActiveSheet.Rows.Count Or rngData.Columns.Count = ActiveSheet.Columns.Count Then Set rngTemp = ActiveSheet.UsedRange 'сбрасываем последнюю ячейку Set rngData = Intersect(rngData, ActiveSheet.UsedRange) End If If rngData Is Nothing Then MsgBox "Сначала укажите диапазон с данными для разбора.", vbExclamation, "Ошибка ввода" refData.SetFocus Exit Sub End If If rngData.Rows.Count = 1 Then MsgBox "В исходном диапазоне должно быть больше одной строки.", vbExclamation, "Ошибка ввода" refData.SetFocus Exit Sub End If Application.ScreenUpdating = False 'копируем данные на отдельный лист для последующего разбора ----------------------------------------------------------------------------------------------- On Error Resume Next Worksheets("TempDataSheet").Delete On Error GoTo 0 Set tws = Worksheets.Add tws.Name = "TempDataSheet" rngData.Copy Destination:=tws.Range("A1") 'переносим ширину столбцов rngData.Copy tws.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths 'убираем объединение ячеек On Error Resume Next tws.Cells.UnMerge On Error GoTo 0 'убираем форматирование, если нужно If Not chkSaveFormat Then 'если простая таблица - убираем форматы tws.Cells.ClearFormats 'если умная таблица - выключаем стиль On Error Resume Next TableName = tws.Range("A1").ListObject.Name Set ActiveTable = tws.ListObjects(TableName) ActiveTable.TableStyle = "" On Error GoTo 0 End If '================================== по значениям заданного столбца ================================================================ If optByColumnValues Then nCol = CInt(ddColumn.Value) 'столбец для разбора 'сортируем по нужному столбцу With tws.Sort .SortFields.Clear .SortFields.Add Key:=Range(Cells(hr + 1, nCol), Cells(rngData.Rows.Count, nCol)) .SetRange tws.Cells(hr + 1, 1).Resize(rngData.Rows.Count - hr, rngData.Columns.Count) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'проходим по выбранному столбцу и заменяем ошибки и пустые ячейки For i = (hr + 1) To rngData.Rows.Count If IsEmpty(tws.Cells(i, nCol)) Then tws.Cells(i, nCol).Value = "Пусто" If IsError(tws.Cells(i, nCol)) Then tws.Cells(i, nCol).Value = CStr(tws.Cells(i, nCol).Value) Next i 'проходим по выбранному столбцу и раскидываем блоки по разным листам startrow = hr + 1 shname = 1 For i = (hr + 1) To rngData.Rows.Count If tws.Cells(i, nCol) <> tws.Cells(i + 1, nCol) Then 'добавляем новый лист Worksheets.Add before:=sourcews Set outws = ActiveSheet 'присваиваем имя листу If optNamesFromCells Then 'имена листов из ячеек shname = Left(tws.Cells(i, nCol), 30) 'убираем из имени листа недопустимые символы и обрезаем до 30 знаков shname = Replace(shname, "/", "") shname = Replace(shname, "\", "") On Error Resume Next If chkReplaceSheets Then Worksheets(shname).Delete outws.Name = shname On Error GoTo 0 End If If optNamesByNumbers Then 'последовательная нумерация листов On Error Resume Next If chkReplaceSheets Then Worksheets(CStr(shname)).Delete outws.Name = shname On Error GoTo 0 shname = shname + 1 End If 'копируем фрагмент данных на новый лист Range(tws.Cells(startrow, 1), tws.Cells(i, rngData.Columns.Count)).Copy outws.Range("B1").PasteSpecial , Transpose:=True 'Тестовое Sheets("Тех").Select Range("A1:A44").Select Copy Destination:=outws.Range("A1") 'переносим ширину столбцов Range(tws.Cells(startrow, 1), tws.Cells(i, rngData.Columns.Count)).Copy outws.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths startrow = i + 1 'добавляем шапку, если нужно If chkHeader Then outws.Rows("1:" & hr).Insert Shift:=xlDown tws.Rows("1:" & hr).Copy Destination:=outws.Cells(1, 1) End If End If Next i End If '======================== по горизонтальным разрывам страницы ======================================================================= If optByPageBreaks Then 'добавляем временный разрыв в конец таблицы исходных данных sourcews.HPageBreaks.Add before:=rngData.Cells(1, 1).Offset(rngData.Rows.Count, 0) startrow = hr + 1 shname = 1 For Each pgbrk In sourcews.HPageBreaks 'добавляем новый лист Set outws = Worksheets.Add(after:=Worksheets(sourcews.index + shname - 1)) 'присваиваем имя листу If optNamesByNumbers Then 'последовательная нумерация листов On Error Resume Next If chkReplaceSheets Then Worksheets(CStr(shname)).Delete outws.Name = shname On Error GoTo 0 shname = shname + 1 End If 'копируем фрагмент данных на новый лист finishrow = pgbrk.Location.Row - rngData.Cells(1, 1).Row Range(tws.Cells(startrow, 1), tws.Cells(finishrow, rngData.Columns.Count)).Copy Destination:=outws.Range("A1") 'переносим ширину столбцов Range(tws.Cells(startrow, 1), tws.Cells(finishrow, rngData.Columns.Count)).Copy outws.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths startrow = finishrow + 1 'добавляем шапку, если нужно If chkHeader Then outws.Rows("1:" & hr).Insert Shift:=xlDown tws.Rows("1:" & hr).Copy Destination:=outws.Cells(1, 1) End If Next pgbrk End If Application.DisplayAlerts = False tws.Delete Application.ScreenUpdating = True Unload MeEnd SubPrivate Sub optByColor_Change() If optByColor Then optNamesByNumbers = True optNamesFromCells.Enabled = False chkSaveFormat = True chkSaveFormat.Enabled = False End IfEnd SubPrivate Sub optByColumnValues_Change() If optByColumnValues Then optNamesFromCells.Enabled = True optNamesFromCells = True chkSaveFormat.Enabled = True End IfEnd SubPrivate Sub optByPageBreaks_Change() If optByPageBreaks Then optNamesByNumbers = True optNamesFromCells.Enabled = False chkSaveFormat.Enabled = True End IfEnd SubPrivate Sub optByRowsCount_Change() If optByRowsCount Then optNamesByNumbers = True optNamesFromCells.Enabled = False chkSaveFormat.Enabled = True End IfEnd SubPrivate Sub UserForm_Activate() refData.Value = Selection.Address ddColumn.ListIndex = 0 ddColorColumn.ListIndex = 0 ddHR.ListIndex = 0End SubPrivate Sub UserForm_Initialize() For k = 1 To 100 ddColumn.AddItem k ddColorColumn.AddItem k Next k For k = 1 To 10 ddHR.AddItem k Next k Me.StartUpPosition = 0 Me.Left = Int(Application.Left + Application.Width / 2 - Me.Width / 2) Me.Top = Int(Application.Top + Application.Height / 2 - Me.Height / 2)End Sub
Application.Workbooks("имя книги с расширением").Sheets("Тех").Range("A1:A44").Copy Destination:=outws.Range("A1")