Сообщения

Спасибо огромное, с Вашим кодом все получилось!
По поводу моего кода, да, я действительно уже его правил, это не то что записал рекордер
[admin]Не цитируйте сообщения полностью - достаточно выделить нужную фразу и нажать ЦИТИРОВАТЬ. п.п. 4.18 Правил форума[/admin]

Теперь осталось прояснить остальные вопросы. В таком виде код мало что прояснит, т.к. чтобы его запустить надо сначала нарисовать формы, с помощью которых отбираются параметры работы кода, потом угадать какие Вы указали при запуске и что за ошибку(или нет) получили.

Спасибо что отвечаете. Ошибки как таковой нет если использовать код как есть, без моих "доработок".
Прикрепил ошибку которую получаю когда пытаюсь выполнить код со своей доработкой. Т.к синтаксиса я не знаю, код доработки брал через запись макроса.

Извините. Прикрепляю код и пример файла

[spoiler=раскрыть для просмотра кода]

Код (vb) Выделить Развернуть

Private Sub btnCancel_Click()
   Unload Me
End Sub


Private 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 Me
End Sub

Private Sub optByColor_Change()
   If optByColor Then
       optNamesByNumbers = True
       optNamesFromCells.Enabled = False
       chkSaveFormat = True
       chkSaveFormat.Enabled = False
   End If
End Sub

Private Sub optByColumnValues_Change()
   If optByColumnValues Then
       optNamesFromCells.Enabled = True
       optNamesFromCells = True
       chkSaveFormat.Enabled = True
   End If
End Sub

Private Sub optByPageBreaks_Change()
   If optByPageBreaks Then
       optNamesByNumbers = True
       optNamesFromCells.Enabled = False
       chkSaveFormat.Enabled = True
   End If
End Sub

Private Sub optByRowsCount_Change()
   If optByRowsCount Then
       optNamesByNumbers = True
       optNamesFromCells.Enabled = False
       chkSaveFormat.Enabled = True
   End If
End Sub

Private Sub UserForm_Activate()
   refData.Value = Selection.Address
   ddColumn.ListIndex = 0
   ddColorColumn.ListIndex = 0
   ddHR.ListIndex = 0
End Sub

Private 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

[/spoiler]

Всем привет. Только только начинаю знакомиться с VBA, возник вопрос.
Стоит задача разбить книгу по листам, для этого на просторах интренета нашел готовый макрос(надстройку)
Все работает, но хочу добавить процедуру шаг "скопировать диапазон с заданного листа, и вставить в активный лист", в коде отметил красным то что добавляю.
Понимаю что сделал неправильно, так не работает, направьте пожалуйста на путь истинный

Код (vb) Выделить Развернуть

            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
[admin]Коды оформляйте тегами VBCode. п.п. 4.25 Правил форума[/admin]