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

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

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

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

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

Ответ
 
Опции темы Поиск в этой теме
Старый 11.06.2020, 16:12   #1
Garrison
Пользователь
 
Регистрация: 16.07.2009
Сообщений: 30
По умолчанию Трансформация большого объема (VBA)

Доброго времени суток, уважаемые форумчане.
В файле, в одном столбце присутствуют данные в виде:

СОШ 17
ДЮСШ 4
93
88
15
22
17
24
19
16
25
14
17
12

ДЮСШ 4
СОШ 17
77
82
25
15
21
30
13
18
18
19

и т.д.
Данных много и они будут меняться. Нужно каждый т.н. блок, транспортировать в строку, а именно
в таком виде:
СОШ 17 ДЮСШ 4 93 88 15 22 17 24 19 16 25 14 17 12
ДЮСШ 4 СОШ 17 77 82 25 15 21 30 13 18 18 19
Файл прилагаю.
Заранее благодарю
Вложения
Тип файла: xlsx Школы.xlsx (42.1 Кб, 2 просмотров)
Garrison вне форума Ответить с цитированием
Старый 11.06.2020, 16:55   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Код:
Option Explicit

Sub fck()
    Dim rng As Range
    Dim i As Integer
    Dim j As Integer
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets(1)
    Set sh2 = Sheets(2)
    j = 1
    With sh1
        For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If .Cells(i, "A").Value <> "" Then
                If rng Is Nothing Then
                    Set rng = .Cells(i, "A")
                Else
                    Set rng = Union(rng, .Cells(i, "A"))
                End If
            Else
                If Not rng Is Nothing Then
                sh2.Cells(j, "A").Resize(1, rng.Cells.Count).Value = _
                            Application.WorksheetFunction.Transpose(rng)
                j = j + 1
                Set rng = Nothing
                End If
            End If
        Next i
    End With
    Set sh1 = Nothing
    Set sh2 = Nothing
    Set rng = Nothing
End Sub
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 11.06.2020, 17:23   #3
Garrison
Пользователь
 
Регистрация: 16.07.2009
Сообщений: 30
По умолчанию

Aleksandr H.,
Большое, человеческое спасибо
Garrison вне форума Ответить с цитированием
Ответ


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

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Трансформация XML m9yt C# (си шарп) 4 17.05.2013 14:28
поиск hex значения в бинарном файле (большого объема) witia03 Общие вопросы Delphi 10 23.05.2012 20:25
Вывод большого объема текста в Delphi NowLast Общие вопросы Delphi 2 29.12.2011 13:11
Сокеты. Отправка текста большого объема. Rapala Работа с сетью в Delphi 2 10.04.2011 16:17
Поиск в файле большого объема za4ot Общие вопросы Delphi 2 26.03.2009 20:26