Вообщем суть проблемы: имеется БД, состоящая из названия, адреса,телефона. Это БД записана в 1 столбец, а данные расположены поочередно, то есть:
1 строка: название 2 строка: адрес 1 3 строка: телефон: 4 строка: email 5 строка: Prefix 6 строка: название 7 строка: адрес 1 8 строка: адрес 2 9 строка: адрес 3 10 строка: телефон: 11 строка: Prefix
и так далее.. строк несколько тысяч. Требуется разбить этот столбец на три колонки по параметрам (названия в названия и т.д.). Знаю простой метод - выделяю ячейки с данными для 1 учреждения, потом клацаю на соседнюю с названием ячейку правой кнопкой => cпециальная вставка => транспонирование. В принципе необходимое действие выполнено. Но, т.к. позиций несколько тысяч, вручную это делать очень долго. Поэтому хотела создать макрос, но проблема в том, что данные могут состоять из разного количества строк для одной компании, хотя последняя строчка всегда одинаково начинается: "Prefix*". Поэтому все ломаю голову как сделать транспонирование с условием проверки до следующей ячейки с записью "Prefix*".
И, вдруг кто-то знает решение, чтобы все телефоны были в одной колонке, emailы в другой.
Sub bb() Dim a As Range, b As Range, c As Range Set b = [A2] Set c = [G2] Do Set a = b Set b = b.Offset(1) Do Until b Like "Prefix*" Or b = "" //Заменила на свою задачу, там было ";" Set b = b.Offset(1) Loop Range(a, b.Offset(-1)).Copy c.PasteSpecial Transpose:=True If Left(c, 2) = "; " Then c = Mid(c, 3) Set c = c.Offset(1) Loop Until b = "" Application.CutCopyMode = False End Sub
[/vba]
Вообщем суть проблемы: имеется БД, состоящая из названия, адреса,телефона. Это БД записана в 1 столбец, а данные расположены поочередно, то есть:
1 строка: название 2 строка: адрес 1 3 строка: телефон: 4 строка: email 5 строка: Prefix 6 строка: название 7 строка: адрес 1 8 строка: адрес 2 9 строка: адрес 3 10 строка: телефон: 11 строка: Prefix
и так далее.. строк несколько тысяч. Требуется разбить этот столбец на три колонки по параметрам (названия в названия и т.д.). Знаю простой метод - выделяю ячейки с данными для 1 учреждения, потом клацаю на соседнюю с названием ячейку правой кнопкой => cпециальная вставка => транспонирование. В принципе необходимое действие выполнено. Но, т.к. позиций несколько тысяч, вручную это делать очень долго. Поэтому хотела создать макрос, но проблема в том, что данные могут состоять из разного количества строк для одной компании, хотя последняя строчка всегда одинаково начинается: "Prefix*". Поэтому все ломаю голову как сделать транспонирование с условием проверки до следующей ячейки с записью "Prefix*".
И, вдруг кто-то знает решение, чтобы все телефоны были в одной колонке, emailы в другой.
Sub bb() Dim a As Range, b As Range, c As Range Set b = [A2] Set c = [G2] Do Set a = b Set b = b.Offset(1) Do Until b Like "Prefix*" Or b = "" //Заменила на свою задачу, там было ";" Set b = b.Offset(1) Loop Range(a, b.Offset(-1)).Copy c.PasteSpecial Transpose:=True If Left(c, 2) = "; " Then c = Mid(c, 3) Set c = c.Offset(1) Loop Until b = "" Application.CutCopyMode = False End Sub
Вижу в файле в ячейках опорные метки типа: Telephone, Facsimile, Email, Prefix(es). Не вижу на что опереться выше этих меток. Или первые пять ячеек (имя, адреса) одного блока, начиная с имени всегда присутствуют в каждом блоке?
В общем, я бы вначале сделал так в колонках В:E на первом листе:
колонка B - сквозная нумерация всех имеющихся строк (так, на всякий случай, будет нелишним)
колонка С - генерируем нумерацию блоков: в ячейке C1: 1 , далее, начиная с ячейки C2, формула:
Код
=ЕСЛИ(ЕОШ(ПОИСК("Prefix";A1));C1;C1+1)
колонка D - генерируем нумерацию строк внутри блоков: в ячейке D1: 1 , далее, начиная с ячейки D2, формула:
Код
=ЕСЛИ(C2=C1;D1+1;1)
колонка E - для первых 5 (постоянных?) безметочных ячеек внутри блока - просто номер из колонки D, далее с 6-й ячейки каждого блока индикация одной из меток: Telephone, Facsimile, Email, Prefix(es); начиная с ячейки E1, формула:
Код
=ЕСЛИ(D1<=5;D1;ЛЕВСИМВ(A1;ПОИСК(":";A1)-1))
Далее я бы подумал далее... А именно - в направлении создания на новом листе таблицы со столбцами - уникальными значениями колонки E, и со строками - номерами блоков, т.е. числами от 1 до максимального из колонки C... Этот лист я назвал "ВытягивающаяТаблица"
Далее в колонке F первого листа можно сцепить номера блока и метки и получить уникальный идентификатор строки
Код
=C1&"_"&E1
Этот идентификатор затем можно сформировать и в ячейках "ВытягивающейТаблицы", окончательная формула для этих ячеек такая:
Результат можно посмотреть в прилагаемом файле. Вот какой-то такой примерно подход к решению задач подобного рода...
Вижу в файле в ячейках опорные метки типа: Telephone, Facsimile, Email, Prefix(es). Не вижу на что опереться выше этих меток. Или первые пять ячеек (имя, адреса) одного блока, начиная с имени всегда присутствуют в каждом блоке?
В общем, я бы вначале сделал так в колонках В:E на первом листе:
колонка B - сквозная нумерация всех имеющихся строк (так, на всякий случай, будет нелишним)
колонка С - генерируем нумерацию блоков: в ячейке C1: 1 , далее, начиная с ячейки C2, формула:
Код
=ЕСЛИ(ЕОШ(ПОИСК("Prefix";A1));C1;C1+1)
колонка D - генерируем нумерацию строк внутри блоков: в ячейке D1: 1 , далее, начиная с ячейки D2, формула:
Код
=ЕСЛИ(C2=C1;D1+1;1)
колонка E - для первых 5 (постоянных?) безметочных ячеек внутри блока - просто номер из колонки D, далее с 6-й ячейки каждого блока индикация одной из меток: Telephone, Facsimile, Email, Prefix(es); начиная с ячейки E1, формула:
Код
=ЕСЛИ(D1<=5;D1;ЛЕВСИМВ(A1;ПОИСК(":";A1)-1))
Далее я бы подумал далее... А именно - в направлении создания на новом листе таблицы со столбцами - уникальными значениями колонки E, и со строками - номерами блоков, т.е. числами от 1 до максимального из колонки C... Этот лист я назвал "ВытягивающаяТаблица"
Далее в колонке F первого листа можно сцепить номера блока и метки и получить уникальный идентификатор строки
Код
=C1&"_"&E1
Этот идентификатор затем можно сформировать и в ячейках "ВытягивающейТаблицы", окончательная формула для этих ячеек такая:
Спасибо большое за старание!! Быть может кому пригодится.. В итоге реализовано все с помощью макроса так (чтобы телефоны, имейлы и веб страницы были по соответствующим колонкам) : [vba]
Код
Sub Макрос1() Dim S As Range, i&, k& i = 1: k = 1 Sheets(2).Cells.ClearContents For Each S In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) If S Like "*Telephone*" Then Sheets(2).Cells(i, 6) = S Else If S Like "*Email*" Then Sheets(2).Cells(i, 7) = S Else If S Like "http:*" Then Sheets(2).Cells(i, 9) = S Else[ If S Like "*Prefix*" Then Sheets(2).Cells(i, 10) = S i = i + 1 k = 1 Else If k = 7 Then k = 8 Sheets(2).Cells(i, k) = S k = Sheets(2).Cells(i, Columns.Count).End(xlToLeft).Column + 1 End If End If End If End If Next End Sub
[/vba]
Спасибо большое за старание!! Быть может кому пригодится.. В итоге реализовано все с помощью макроса так (чтобы телефоны, имейлы и веб страницы были по соответствующим колонкам) : [vba]
Код
Sub Макрос1() Dim S As Range, i&, k& i = 1: k = 1 Sheets(2).Cells.ClearContents For Each S In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) If S Like "*Telephone*" Then Sheets(2).Cells(i, 6) = S Else If S Like "*Email*" Then Sheets(2).Cells(i, 7) = S Else If S Like "http:*" Then Sheets(2).Cells(i, 9) = S Else[ If S Like "*Prefix*" Then Sheets(2).Cells(i, 10) = S i = i + 1 k = 1 Else If k = 7 Then k = 8 Sheets(2).Cells(i, k) = S k = Sheets(2).Cells(i, Columns.Count).End(xlToLeft).Column + 1 End If End If End If End If Next End Sub
Лихо! В принципе мне понравилось. Со своей стороны посмел немножко Вас упростить и чуть-чуть изменить. Изменить - потому что не очень понял про манипуляции с 7 и 8 столбцами (If k = 7 Then k = 8), а также откуда возник "http" и куда пропал "Facsimile". В итоге отредактированный макрос приводит к такому же результату, что и решение на формулах в моем предыдущем сообщении: [vba]
Код
Sub Макрос2() Dim S As Range, i&, k&, sht As Worksheet, rng As Range
Set sht = Sheets(2) 'чтобы менять в одном месте, если вдруг захотим другой лист sht.Cells.ClearContents 'квалификатор Sheets(1) - чтобы макрос правильно работал при любом активном листе Set rng = Sheets(1).Range("A1:A" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
i = 1: k = 1 For Each S In rng.Cells 'для наглядности, что перебираем именно ячейки диапазона If S Like "*Telephone*" Then sht.Cells(i, 6) = S ElseIf S Like "*Facsimile*" Then sht.Cells(i, 7) = S ElseIf S Like "*Email*" Then sht.Cells(i, 8) = S ElseIf S Like "*Prefix*" Then sht.Cells(i, 9) = S i = i + 1: k = 1 Else sht.Cells(i, k) = S k = k + 1 End If Next End Sub
Лихо! В принципе мне понравилось. Со своей стороны посмел немножко Вас упростить и чуть-чуть изменить. Изменить - потому что не очень понял про манипуляции с 7 и 8 столбцами (If k = 7 Then k = 8), а также откуда возник "http" и куда пропал "Facsimile". В итоге отредактированный макрос приводит к такому же результату, что и решение на формулах в моем предыдущем сообщении: [vba]
Код
Sub Макрос2() Dim S As Range, i&, k&, sht As Worksheet, rng As Range
Set sht = Sheets(2) 'чтобы менять в одном месте, если вдруг захотим другой лист sht.Cells.ClearContents 'квалификатор Sheets(1) - чтобы макрос правильно работал при любом активном листе Set rng = Sheets(1).Range("A1:A" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
i = 1: k = 1 For Each S In rng.Cells 'для наглядности, что перебираем именно ячейки диапазона If S Like "*Telephone*" Then sht.Cells(i, 6) = S ElseIf S Like "*Facsimile*" Then sht.Cells(i, 7) = S ElseIf S Like "*Email*" Then sht.Cells(i, 8) = S ElseIf S Like "*Prefix*" Then sht.Cells(i, 9) = S i = i + 1: k = 1 Else sht.Cells(i, k) = S k = k + 1 End If Next End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
В принципе мне понравилось. Со своей стороны посмел немножко Вас упростить и чуть-чуть изменить. Изменить - потому что не очень понял про манипуляции с 7 и 8 столбцами (If k = 7 Then k = 8), а также откуда возник "http" и куда пропал "Facsimile". В итоге отредактированный макрос приводит к такому же результату, что и решение на формулах в моем предыдущем сообщении: 
