Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
28.03.2024, 13:59:06

Войти
Хотите поблагодарить участника за дельный совет? Нажмите [Повысить]. Так вы заслуженно поднимите репутацию активному участнику.
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Разобрать книгу по листам
Страниц: [1]   Вниз
Печать
Автор Тема: Разобрать книгу по листам  (Прочитано 5753 раз)
0 Пользователей и 1 Гость смотрят эту тему.
Антон_87
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« : 23.07.2021, 10:41:53 »

Всем привет. Только только начинаю знакомиться с 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

Комментарий администратора Коды оформляйте тегами VBCode. п.п. 4.25 Правил форума
« Последнее редактирование: 23.07.2021, 10:48:02 от Дмитрий Щербаков(The_Prist) » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #1 : 23.07.2021, 10:47:40 »

ну т.е. Вы решили, что не видя ни полного кода, ни данных, с которыми работаете, ни понимания что значит "так не работает" можно хоть сколь-нибудь вменяемый ответ дать?  Улыбка
Не работает, это как? Ошибка появляется, результат не тот или что еще?

P.S. Коды оформляйте тегами VBCode. п.п. 4.25 Правил форума
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Антон_87
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« Ответ #2 : 23.07.2021, 11:10:41 »

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

spoiler for раскрыть для просмотра кода:
Код: (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

« Последнее редактирование: 23.07.2021, 12:16:18 от Дмитрий Щербаков(The_Prist) » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #3 : 23.07.2021, 12:02:13 »

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

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Антон_87
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« Ответ #4 : 23.07.2021, 12:09:50 »

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

Спасибо что отвечаете. Ошибки как таковой нет если использовать код как есть, без моих "доработок".
Прикрепил ошибку которую получаю когда пытаюсь выполнить код со своей доработкой. Т.к синтаксиса я не знаю, код доработки брал через запись макроса.
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #5 : 23.07.2021, 12:14:32 »

1. Необходимо указать из какой книги берете лист. Сейчас программа не находит его внутри модуля формы и ругается.
2. Откуда вообще взяли такой синтаксис копирования: Copy Destination:=outws.Range("A1")? К чему у Вас тут Copy относится? Может что-то лишнее удалили или не все скопировали из макроса? Например, где-то по пути потеряли Selection...
3. Select вообще лишний, можно без него спокойно обойтись.
В итоге должно получиться что-то вроде:
Код: (vb)
Application.Workbooks("имя книги с расширением").Sheets("Тех").Range("A1:A44").Copy Destination:=outws.Range("A1")
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Антон_87
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« Ответ #6 : 23.07.2021, 12:30:48 »

Спасибо огромное, с Вашим кодом все получилось!
По поводу моего кода, да, я действительно уже его правил, это не то что записал рекордер Строит глазки
Комментарий администратора Не цитируйте сообщения полностью - достаточно выделить нужную фразу и нажать ЦИТИРОВАТЬ. п.п. 4.18 Правил форума
« Последнее редактирование: 23.07.2021, 12:39:47 от Дмитрий Щербаков(The_Prist) » Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru