Excel VBA: Копирование ячеек на другой лист

Автор Rus23, 21 февраля 2017, 12:53

Rus23

Добрый день.
Помогите, пожалуйста, доработать макрос.
В файл добавляются строки с номерами магазина и другой информацией.
Автоматически создаются новые листы в книге по № магазинов и вставляется в эти листы из листа "шаблон" необходимый формат.
Как доработать макрос так, что бы при создании нового листа по № магазина так же копировалась информация (столбец C в F, столбец D в E)  об этом магазине на этот лист?

    For Each iCell In Sheets("СТ").[B3:B100]
        If iCell.Text = "" Then GoTo Sled
        Set sh = Sheets(iCell.Text)
        If Err Then
            Sheets("Шаблон").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = iCell.Text
        Else
            Err.Clear
        End If
Sled:
    Next

Администратор

sh - это лист, из которого нужно скопировать данные?
Просто берёте и копируете:
sh.Columns("C").Copy Activesheet.Columns("F")

Rus23

Макрос тогда копирует в каждый лист все строки (т.е. все магазины). А необходимо копировать только одну строку в каждый соответствующий лист.
Т.е. если №2, то создается лист с названием 2 и туда автоматически должно копироваться значение из строки, где №2.

    For Each iCell In Sheets("СТ").[B3:B100]
        If iCell.Text = "" Then GoTo Sled
        Set sh = Sheets(iCell.Text)
        If Err Then
            Sheets("Шаблон").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = iCell.Text
            Sheets("СТ").Columns("C").Copy ActiveSheet.Columns("F")
        Else
            Err.Clear
        End If
Sled:
    Next

Администратор

В sh, в столбце с названиями магазинов нужно найти нужную строку.
Для этого можно использовать разные способы. Например, можно использовать эксель-функцию ПОИСКПОЗ:

Схематичный код между "If Err Then" и "Else":

    Dim r As Long
   
    ' Поиск нужной строки с помощью эксель-функции ПОИСКПОЗ.
        ' Если не знаете эту функцию, то посмотрите справку.
    r = WorksheetFunction.Match("искомый магазин", sh.Columns("A"), 0)

    ' Копирование строки.
    sh.Rows(r).Copy ActiveSheet.Rows(нужная строка)

Rus23

Наверное я не совсем понятно объясняю.
В файл каждый раз заносятся разные магазины. Заранее невозможно предугадать какие номера будут.
Поэтому необходимо копировать и вставлять строку во вновь автоматически создаваемый лист.
Допустим, 2 магазина. По нажатию на кнопку макрос создает два листа с номерами этих магазинов, и должен копировать соответствующие строки в эти листы.
Я знаю как копировать и вставлять и тд. Но конкретно реализовать копирование ячейки в строке определенных магазинов в новый лист с наименованием магазина не получается.

Администратор

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

Весь ваш код я не буду смотреть.

Rus23

Сделала как Вы сказали. По нажатию на кнопку "создание листов" создаются три листа: 56, 78, 34.
Пытаюсь реализовать макрос, что бы копировать столбцы C и D. Во вложении 2 файла. Первый с макросом (Пример).
Второй как должно быть (Пример2).

[вложение удалено администратором]

Администратор

Вообще, это задание для использования в жизни или это учебное задание для изучения программирования?

Администратор

С обработкой ошибок нестыковка. Я сразу не заметил.
Эти действия в вашем коде делаются, если происходит ошибка:
Sheets("Шаблон").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = cel.Text

Очищать ошибку нужно здесь же, а не после Else. В вашем случае после возникновения первой ошибки далее всегда ошибка.

Правильно так:
If Err Then
    Sheets("Шаблон").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = cel.Text
    Err.Clear
End If

Администратор

Код
Sub Листы()
   
    Dim sh As Worksheet, cel As Range
    Dim lr As Long
   

    '12. создание листов
    On Error Resume Next
   
    For Each cel In Sheets("СТ").[B3:B100]
       
        ' Если ячейка пустая, то переходим на следующую строку.
        If cel.Text = "" Then GoTo Sled
       
        ' Присваивание листу имени "sh".
        Set sh = Sheets(cel.Text)
       
        ' Если нет листа.
        If Err Then
            ' Создание листа.
            Sheets("Шаблон").Copy After:=Sheets(Sheets.Count)
            ' Присвоение листу имени "sh".
            Set sh = ActiveSheet
            ' Переименование листа.
            sh.Name = cel.Text
            ' Сброс ошибки, чтобы поймать ошибку в следующий раз.
            Err.Clear
        End If
       
        ' Копирование данных из одного листа в другой.
        ' Определение, в какую строку нужно вставить данные на листе-результате.
            ' При использовании "End", если на листе есть скрытые строки,
            ' то может быть неправильный результат.
        lr = sh.Cells(sh.Rows.Count, "F").End(xlUp).Row + 1
        ' Копирование данных.
        sh.Cells(lr, "F").Value = cel.EntireRow.Columns("A").Value
        sh.Cells(lr, "G").Resize(, 2).Value = cel.EntireRow.Columns("C:D").Value
       
Sled:
    Next cel
   
    ' Отключение перехватчика ошибок, чтобы поймать непредвиденные ошибки.
    On Error GoTo 0
   
End Sub
[свернуть]

Rus23


Rus23

Доброго времени суток.
Не подскажете по этому макросу еще кое-что, пожалуйста.
Макрос, который обсуждался выше, создает новые листы с наименованием магазинов.
Но проблема в том, что иногда магазины идут через дробь /, а наименование листа не может содержать этот символ.
Как сделать так, что бы макрос брал наименование магазина, создавал лист с этим наименованием, но когда вдруг встречается этот символ, то менял его, скажем, на символ нижнего подчеркивания?

Администратор

' Можно не проверять, есть дробь или нет, а просто всегда делать замену. Если дроби нет, то ничего не изменится, если дробь есть, то она будет заменена.
            ' Переименование листа.
            sh.Name = Replace(cel.text, "/", "_")