Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 25.06.2016, 11:09   #1
zlotaust
Новичок
Джуниор
 
Регистрация: 25.06.2016
Сообщений: 1
По умолчанию Перенос данных из одного листа одной таблицы в создаваемые листы другой таблицы

Доброго времени суток! Подскажите пожалуйста как написать макрос в Excel для переноса данных из одного листа одной таблицы в создаваемые листы другой таблицы. Условия такие: есть таблица (Test), имеющая один лист (Лист1) с данными в трех столбцах, необходимо перенести информацию из ячеек столбцов "В" и "С" в другую таблицу (Nado), таким образом что ячейки первого столбца "А" первой таблицы (Test) должны стать названиями листов второй таблицы (Nado), при совпадении значений ячеек первого столбца "А" новая страница не должна создаваться, строки переносятся только на тот лист, который имеет название первой ячейки строки.
То есть нужен такой механизм:
1) копируем в буфер значение первой ячейки А1 таблицы Test, открываем таблицу Nado, создаем лист с именем из буфера (значение ячейки А1 таблицы Test);
2) копируем значения первой строчки ячеек "В1" и "С1" таблицы Test, соответственно, в ячейки "А1" "В1" первого листа (название="А1" таблицы Test) таблицы Nado;
3) далее сравниваем значение ячейки "А1" таблицы Test со значением ячейки "В1" таблицы Test, если "равно", то продолжаем записывать на тот же лист (название="А1" таблицы Test) таблицы Nado (В2 и С2 соответственно в А2 и В2), если "не равно", то создаем новый лист в таблице Nado c таким названием и копируем ячейки как описано выше (В2 и С2 таблицы Test соответственно в А1 и В1 нового листа таблицы Nado);
4) продолжаем до тех пор пока не кончатся данные.

Спасибо за Ваше потраченное время и силы!
Вложения
Тип файла: xlsx test.xlsx (8.4 Кб, 16 просмотров)
Тип файла: xlsx Nado.xlsx (12.1 Кб, 15 просмотров)
zlotaust вне форума Ответить с цитированием
Старый 25.06.2016, 11:25   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Если test-столбец А не отсортирован, что тогда?

upd:
вариант разноса по листам
Код:
Sub fa()
    Dim r As Long, rr As Long
    r = Range("A5000").End(xlUp).Row
    Dim i As Long
    Dim s As Worksheet
    For i = 1 To r
        If i = 1 Then
            Set s = Sheets.Add(After:=Sheets(Sheets.Count))
            s.Name = Sheets(1).Cells(i, 1)
            Sheets(1).Range("B" & i & ":C" & i).Copy
            s.Cells(1, 1).PasteSpecial
            rr = 2
        ElseIf Sheets(1).Cells(i - 1, 1) <> Sheets(1).Cells(i, 1) Then
            Set s = Sheets.Add(After:=Sheets(Sheets.Count))
            s.Name = Sheets(1).Cells(i, 1)
            Sheets(1).Range("B" & i & ":C" & i).Copy
            s.Cells(1, 1).PasteSpecial
            rr = 2
        Else
            Sheets(1).Range("B" & i & ":C" & i).Copy
            s.Cells(rr, 1).PasteSpecial
            rr = rr + 1
        End If
    Next
   Set s = Nothing
End Sub
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.

Последний раз редактировалось Aleksandr H.; 25.06.2016 в 12:04. Причина: добавил код
Aleksandr H. вне форума Ответить с цитированием
Старый 25.06.2016, 11:58   #3
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

из нормально организованных данных Вам нужно получить СВАЛКУ страниц??? интересное решение!

если теперь в файле несколько тысяч страниц:
как выяснить есть в нем страница с определенным именем?
как ее найти?

такой файл есть смысл делать только если это задача от начальника, а данными удобнее пользоваться, когда они в одном большом списке
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 25.06.2016, 12:27   #4
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Если test-столбец А не отсортирован, что тогда?
тогда нужно использовать словарь с коллекциями -
сперва пробежаться по столбцу и собрать в словарь все номера строк - каждому слову/названию свою коллецию
затем пробежаться по словарю и создавать и копировать, создавать и копировать... просто и прозрачно.
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 25.06.2016, 12:46   #5
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

останется только написать определенное количество макросов для обработки этих сотен или тысяч страниц...

что тоже довольно очевидно
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 25.06.2016, 14:14   #6
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Словарь с коллекциями:
Код:
Option Explicit

Sub tt()
    Dim a, i&, ii&, x&, t$, k, el, wb As Workbook

    Application.ScreenUpdating = False
    a = ActiveSheet.[a1].CurrentRegion.Value

    'создали словарь, собрали уникальные с номерами строк
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1    'текстовое сравнение
        For i = 1 To UBound(a)    'цикл по данным
            t = a(i, 1)   'критерий, тут иногда trim() ещё может нужен...
            'If Len(t) > 2 Then 'так можно отбросить пустые строки, нет в примере
            ' если нет в словаре, добавляем с коллекцией
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add i    'в коллекцию критерия добавляем номер строки
            'End If
        Next

        Set wb = Workbooks.Add(1)
        'перебор словаря/коллекций, выгрузка и сохранение файлов
        For Each k In .keys    'перебор ключей
            ReDim aa(1 To .Item(k).Count, 1 To 7)    ' создаём выгружаемый массив
            ii = 0    'обнуляем счётчик его строк
            For Each el In .Item(k)    'цикл по коллекции ключа
                ii = ii + 1    'счётчик строк выгружаемого массива
                'цикл по строке, полученной из коллекции, копирование данных
                For x = 1 To UBound(a, 2): aa(ii, x) = a(el, x): Next
            Next
            With wb.Sheets.Add(, Sheets(wb.Sheets.Count))    'создаём лист
                .Name = k 'меняем имя
                .Cells(1).Resize(UBound(aa), UBound(aa, 2)) = aa    'выгружаем массив
            End With
        Next
    Application.DisplayAlerts = False: wb.Sheets(1).Delete: Application.DisplayAlerts = True 'молча удаляем ненужный лист
    End With

    Application.ScreenUpdating = True

End Sub
А сотни листов пусть обрабатывает заказчик этого безобразия...
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Перенос данных с одного листа на другой 1k0naMyst Microsoft Office Excel 0 17.10.2012 11:01
Перенос данных с одного листа на другой Melnan Microsoft Office Excel 0 01.04.2011 11:58
Перенос данных из одного листа в другой Светланка85 Microsoft Office Excel 2 07.09.2009 09:18
авт. перенос данных из нескольких столбцов одной таблицы в один столбец другой таблицы A_ALL Microsoft Office Access 7 24.08.2009 21:13