Копирование n столбцов на новый лист с заданными заголовками

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Программирование и базы данных (http://forum.oszone.net/forumdisplay.php?f=21)

Копирование n столбцов на новый лист с заданными заголовками

Как реализовать функцию на море столбцов?
А то переписывать одно и тоже под конкретную задачу не хорошо

Код:

Public Sub Copy4Columns(Sheets_ As String, column1 As String, column2 As String, column3 As String, column4 As String) 'копируем на новый лист 4 столбца

    Application.ScreenUpdating = False

    If ActiveSheet.Index > 1 Then

        Sheets.Add Before:=Sheets(ActiveSheet.Index)

    Else

        Sheets.Add After:=Sheets(ActiveSheet.Index)

    End If

    ActiveSheet.Name = Sheets_

    With Worksheets(ActiveSheet.Index - 1)

        oboz = .Cells.Find(What:=column1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(oboz).Copy

        Columns(1).Select

        ActiveSheet.Paste

        nop = .Cells.Find(What:=column2, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(nop).Copy

        Columns(2).Select

        ActiveSheet.Paste

        razr = .Cells.Find(What:=column3, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(razr).Copy

        Columns(3).Select

        ActiveSheet.Paste

        Tpz = .Cells.Find(What:=column4, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(Tpz).Copy

        Columns(4).Select

        ActiveSheet.Paste

    End With

    Application.ScreenUpdating = True

End Sub

blackeangel, добавили лист по Sheets.Add() — сразу берите возвращаемую методом ссылку на новый рабочий лист и работайте с ней. И никаких последующих игр с ActiveSheet и Worksheets(ActiveSheet.Index - 1).

Будет проще, если Вы поясните, что означает:

Код:

        oboz = .Cells.Find(What:=column1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(oboz).Copy

        Columns(1).Select

        ActiveSheet.Paste

И пример вызова процедуры покажите.

Цитата:

Цитата Iska (Сообщение 2734111)

Код:

        oboz = .Cells.Find(What:=column1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(oboz).Copy

        Columns(1).Select

        ActiveSheet.Paste

И пример вызова процедуры покажите.

1. Не понял про sheet.add
2. Ищем столбец на предыдущем листе по его заголовку, копируем весь столбец и вставляем на новый
3. Пример вызова
Copy4Columns("Имя_Нового_Листа","имя_столбца1","Имя_столбца2","Имя_столбца3","имя_столбца4")

Цитата:

Цитата blackeangel

2. Ищем столбец на предыдущем листе по его заголовку, »

Вот хрен бы догадался :).

Попробуйте так:

Скрытый текст

Код:

Option Explicit



Sub SampleCall()

    Copy4Columns "Имя_Нового_Листа", Array("имя_столбца1", "Имя_столбца2", "Имя_столбца3", "имя_столбца4")

End Sub



Public Sub Copy4Columns(strNewWorksheetName As String, arrTitles As Variant)

    Dim objSourceWorksheet As Worksheet

    Dim objDestWorksheet As Worksheet

    

    Dim strTitle As Variant

    

    Dim objSourceRange As Range

    Dim objDestRange As Range

    

    

    Application.ScreenUpdating = False

    

    

    Set objSourceWorksheet = ActiveSheet

    

    If objSourceWorksheet.Index > 1 Then

        Set objDestWorksheet = Sheets.Add(Before:=objSourceWorksheet)

    Else

        Set objDestWorksheet = Sheets.Add(After:=objSourceWorksheet)

    End If

    

    

    With objDestWorksheet

        .Name = strNewWorksheetName

        

        For Each strTitle In arrTitles

            Set objSourceRange = objSourceWorksheet.UsedRange.Find(What:=strTitle, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)

            

            If Not objSourceRange Is Nothing Then

                If .UsedRange.Count = 1 Then

                    Set objDestRange = .UsedRange.EntireColumn

                Else

                    Set objDestRange = .UsedRange.Offset(ColumnOffset:=1).EntireColumn

                End If

                

                If Not objSourceRange.EntireColumn.Copy(objDestRange) Then

                    Debug.Print "Can't copy column [" & objSourceRange.EntireColumn.Address(External:=True) & "] into worksheet [" & .Name & "]."

                End If

            Else

                Debug.Print "Can't find value [" & strTitle & "] in worksheet [" & objSourceWorksheet.Name & "]."

            End If

        Next

    End With

    

    Set objDestWorksheet = Nothing

    Set objSourceWorksheet = Nothing

    

    Application.ScreenUpdating = True

End Sub

Цитата:

Цитата blackeangel

1. Не понял про sheet.add »

Выделил в коде. Точно так же мы сразу запоминаем ссылку на текущий активный рабочий лист в переменной objSourceWorksheet и далее работаем именно с ней, независимо от того, какой лист в процессе может стать активным.

Iska, не, так кривоватенько)
во первых, заменяет последним столбцом все предыдущие
Второе, берет не нужный лист, тк мне надо index-1, но это бог с ним, не проблема, а вот с первым беда.
По первой проблеме-видимо надо завязываться на кол-во элементов массива заголовков. И вставлять их по очереди в определенный столбец, который равен порядковому номеру заголовка столбца+1 в массиве. Как это реализовать в коде - не допер, тк не понятно где кто копируется и вставляется.
И ещё вопрос, как вставить лист, так чтоб он был неактивным?

Мой вариант решения задачи таков:

Код:

Public Sub Copy4Columns2(Sheets_ As String, arrTitles As Variant) 'копируем на новый лист n столбцов

Dim strTitle As Variant

    Application.ScreenUpdating = False

    If ActiveSheet.Index > 1 Then

        Sheets.Add Before:=Sheets(ActiveSheet.Index)

    Else

        Sheets.Add After:=Sheets(ActiveSheet.Index)

    End If

    ActiveSheet.Name = Sheets_

    i = 0

For Each strTitle In arrTitles

i = i + 1

    With Worksheets(ActiveSheet.Index - 1)

        oboz = .Cells.Find(What:=strTitle, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column

        .Columns(oboz).Copy

        Columns(i).Select

        ActiveSheet.Paste

    End With

Next

    Application.ScreenUpdating = True

End Sub

Цитата:

Цитата blackeangel

во первых, заменяет последним столбцом все предыдущие »

Вообще-то не так :). Но ошибка присутствует, надо заменить в ветви Else:

Код:

Set objDestRange = .UsedRange.Offset(ColumnOffset:=1).EntireColumn

на:

Код:

Set objDestRange = .Columns.Item(.UsedRange.Columns.Count).Offset(ColumnOffset:=1).EntireColumn

Цитата:

Цитата blackeangel

Второе, берет не нужный лист, тк мне надо index-1, »

Где берёт? От чего берёт? Поясните словами, где и что нужно сделать.

Цитата:

Цитата blackeangel

По первой проблеме-видимо надо завязываться на кол-во элементов массива заголовков. И вставлять их по очереди в определенный столбец, который равен порядковому номеру заголовка столбца+1 в массиве. »

Можно и так. Но проще ориентироваться на количество столбцов уже заполненной части целевого Рабочего листа, то есть — танцевать от .UsedRange.Columns (поскольку мы заполняем от самого первого столбца — этого будет достаточно).

Цитата:

Цитата blackeangel

И ещё вопрос, как вставить лист, так чтоб он был неактивным? »

Никак. И я Вам написал выше — нужно прекращать порочную практику увязки кода с активностью Рабочих листов и книг. Вошли в код — сразу запомнили ссылку на активный Рабочий лист в переменной, если он Вам понадобится. Добавляете лист — сразу запоминаете возвращаемую методом ссылку в переменной. И далее работаете только с этими объектными переменными. А Вы опять Copy-Paste с увязкой на ActiveSheet:

Код:

        .Columns(oboz).Copy

        Columns(i).Select

        ActiveSheet.Paste

продолжаете пользовать.

Iska, последний вопрос был общим, не относящийся к данной теме.
На счёт порочного круга - мне так понятно что происходит, а ваш код темный лес, ибо знаний в этом направлении у меня нет вообще.

Цитата:

Где берёт? От чего берёт? Поясните словами, где и что нужно сделать.

У вас запоминает последний активный лист, а мне он не нужен. Берется лист до него. Например, есть 2 листа, последний активный, а данные берутся с первого. У вас, с последнего активного, как я понимаю ваши слова.

Цитата:

Цитата blackeangel

активный лист, а мне он не нужен. Берется лист до него. »

А в чём смысл копирования в новый лист не с активного Рабочего листа?

Цитата:

Цитата blackeangel

а ваш код темный лес, ибо знаний в этом направлении у меня нет вообще. »

Спрашивайте, поясню.

Можете также, временно закомментировав Application.ScreenUpdating, прогнать код по шагам под отладчиком по F8, просматривая по ходу движения потребное хоть ручками в окне Immediate, хоть в окне Watches:

Скрытый текст