Как написать макрос в Excel, который строку данных из ячейки «рассортировывал» бы в таблицу?

Question

[Алексей Смирнов]

Здравствуйте.

Есть вот такая строка данных:

1. Switzerland (7.587) 2. Iceland (7.561) 3. Denmark (7.527) 4. Norway (7.522) 5. Canada (7.427) 6. Finland (7.406) 7. Netherlands (7.378)

Эта строка данных расположена в одной ячейке таблицы Excel.

Мне необходимо написать макрос на языке Visual Basic for Application, который эту строку данных ("рассортировал") превратил бы в таблицу в программе Excel. То есть чтобы в 1-м столбце таблицы Excel располагалась бы нумерация рейтинга стран, во 2-м столбце названия стран, в 3-м числовые значения из скобок ().

Чтобы вот так получилось (каждое значение в своей ячейке таблицы Excel):
1 Switzerland 7,587
2 Iceland 7,561
3 Denmark 7,527
4 Norway 7,522
5 Canada 7,427

Как это можно реализовать?

Answer 1

[Saboteur]

У вас не вопрос а задача, что не по теме ресурса.
Но вы можете записать последовательность клавиш, и выполнить следующее:
1. Данные - по столбцам, с разделителем закрываяющая скобка ")" - разделите по ячейкам.
2. Затем скопировать и транспонировать ячейки - перевернете горизонтальное в вертикальное
3. Затем текст-замена, убираете скобки (меняете на пустоту)
4. Затем еще раз данные по столбцам, с разделителем пробелом.

Записанный макрос можно посмотреть в VB

Answer 2

[Алексей Смирнов]

Еще для реализации данной задачи я написал вот такой макрос:
Он учитывает, что названия некоторых стран могут состоять из нескольких слов, к примеру "United Arab Emirates". Может кому пригодиться в будущем.

Public Sub ConvertRowToTable()

    Dim textString As String
    Dim textArray() As String
     
    textString = ActiveCell.Text    'Получаем строку из активной (выдененной пользователем) ячейки
    textArray() = Split(textString) 'Разбиение строки на подстроки, которые будут храниться в элементах массива.
                                    'Разбиение осуществлялось через пробелы



    'Цикл объединения элементов массива, слов, разделенных ранее пробелами (дело в том, что функция Split, слова,...
    '...разделенные пробелами, разносит в разные элементы массива, и эти слова необходимо объединять в один элемент массива
    m = 0
    For i = LBound(textArray) To UBound(textArray)
      
        If i = 0 Then
            i = 1
        End If
        
        Check1 = textArray(i - 1) Like "*[a-z]*" 'Проверка наличия буквенных символов в предыдущей строке элемента массива
        Check2 = textArray(i) Like "*[a-z]*"     'Проверка наличия буквенных символов в текущей строке элемента массива
      
      
        If Check1 And Check2 Then                'Если в строках предыдущего и текущего элементах массива содержиться буквенный текст, то...
                   
           textArray(i - 1) = textArray(i - 1) & " " & textArray(i) '...конкатенируем строки текущего и предыдудщего элементов массива
           
           m = m + 1
           
           For n = i To UBound(textArray) - m    'Цикл осуществляющий сдвиг всех элементов массива на m
        
                textArray(n) = textArray(n + 1)
                 
           Next n
            
        textArray(n) = ""  'Обнуляем строки последних ненужных элементов массива
           
        i = i - 1  'Осуществляет возврат цикла назад, для повторной проверки одновременного наличия буквенных символов в строке,...
                   '...уже нового предыдущего элемента массива и текущего элемента массива
                    
        End If
               
    Next i



    'Цикл формирования таблицы из массива данных
    j = 0
    n = ActiveCell.Column  'Возвращает номер стобца активной ячейки
    k = ActiveCell.Row + 1 'Возвращает номер строки активной ячейки и + 1
    For i = LBound(textArray) To UBound(textArray)
    
        If j >= 3 Then 'Если j >= 3, то переходим на новую строку и возвращаемся на изначальный столбец
            j = 0      'возвращение на изначальный столбец
            k = k + 1  'переход на новую строку
        End If

        textArray(i) = Replace(textArray(i), "(", "") 'Убираем ненужные скобки
        textArray(i) = Replace(textArray(i), ")", "") 'Убираем ненужные скобки
        
        Sheets(1).Cells(k, j + n) = textArray(i)
                
        j = j + 1
        
    Next i



End Sub