Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA Преобразование одномерной таблицы в двумерную, Оптимизация кода, поиск более изящного решения
 
#1
15.02.2018 08:53:59
Доброго времени суток. В файле пример - изначальная структура и желаемый вид. Вроде не особо сложная задачка, если бы не эти "Да", "Нет" (реальный исходник - из выгрузки опросника, которая совсем непригодна для анализа).
Макрос я написал, который справляется с задачей, но вот изящным решение уж точно не назвать - абсолютная привязка в некоторых моментах, использование Selection. Быть может, с этой задачей можно справиться более красивым образом?
 
 
 
#2
15.02.2018 11:21:45
решение через мышкоклацание в PQ. Вам нужна функция типа fill down, в надстройке PLEX вроде она есть  
 
 
 
#3
15.02.2018 11:54:29
Надо же, все обхожу стороной PQ, а как быстро все можно сделать.
Особенно понравилась логика да-нет распредилить в один вспомогательный столбец, а вопросы в другой, и уже затем объединять. Я что-то не додумался до этого принципа, а так можно было бы обойтись без счетчика myTrigger в макросе.
 
 
 
#4
15.02.2018 12:21:50
Код
Sub ReMake()
  Dim ar, r&, v$, o$
  [c1] = ")": ar = [b1].CurrentRegion.Value: ar(1, 2) = "Результат": ar(1, 3) = Empty: [c1] = Empty
  For r = 2 To UBound(ar)
    If IsEmpty(ar(r, 1)) Then
      ar(r, 3) = v & o
    Else
      If ar(r, 1) = "Да" Or ar(r, 1) = "Нет" Then o = ar(r, 1) Else o = "": v = ar(r, 1)
      ar(r, 1) = Empty
    End If
  Next
  Range("E:G").ClearContents:  Cells(1, 5).Resize(UBound(ar), 3).Value = ar
End Sub
Изменено: Ігор Гончаренко - 15.02.2018 12:25:04
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#5
15.02.2018 12:46:31
Ну, что сказать, слов нет. За один проход, без метаний по листу - здорово. Массивы - сила...
Просто интересно: v - это вопрос, o - ответ? Сложно было понять поначалу, пока не начал их так расшифровывать
Изменено: Alias - 15.02.2018 12:49:48
 
 
 
#6
15.02.2018 13:05:22
Цитата
Просто интересно: v - это вопрос, o - ответ?
да, я руководствовался именно этими ассоциациями и если бы знал английский скорее всего назвал бы их как-то Q и A
Изменено: Ігор Гончаренко - 15.02.2018 13:07:45
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
15.02.2018 15:10:39
Как вариант
Код
Sub test2()
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
    If Cells(i, "B") = "" Then
        If Left(Cells(i, "A"), 1) = "В" Then
            s = Cells(i, "A")
            b = Cells(i, "A")
        Else
            s = b + Cells(i, "A")
        End If
    Else: Cells(i, "C") = s
    End If
    Columns(1).ClearContents
Next
End Sub
Мой канал
 
 
 
#8
15.02.2018 15:16:19
Еще вариант, похожий на код от Ігор Гончаренко,  но немного другой.
Код
Sub test_1()
    Dim arr(), i&, itxt$, ltxt$
    i = Range("b" & Rows.Count).End(xlUp).Row
    arr = Range([a1], Cells(i, "c")).Value
    For i = 1 To UBound(arr)
        If UCase(arr(i, 1)) Like UCase("*вопрос*") Then itxt = arr(i, 1): ltxt = "": arr(i, 1) = Empty
        If UCase(arr(i, 1)) = UCase("да") Or UCase(arr(i, 1)) = UCase("нет") Then ltxt = arr(i, 1): _
            arr(i, 1) = Empty
        If Not IsEmpty(arr(i, 2)) Then arr(i, 3) = itxt & ltxt
    Next i
    Range("d1").Resize(UBound(arr), 3) = arr
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#9
16.02.2018 15:03:58
Спасибо всем!
Я тут попытался преобразовать задачу в реально полезную двумерную таблицу с отдельным столбцом для каждого вопроса. С задачей справился, но уверен, что это всем говнокодам говнокод. Выкрутиться я смог, но чувствую, каких-то инструментов мне не хватает. Если парой предложений подскажете, в каком направлении изучать VBA для того, чтобы более красиво справиться с этой задачей - буду признателен.
Вот сам код  для тех, кто давно не смеялся:
Код
Sub test3()
myArr = Range("B3:B41").Value
'Формирование столбца фамилий (столбец С)
For i = 1 To UBound(myArr)
    If myArr(i, 1) Like "*амилия*" Then
        Cells(i + 2, 3) = myArr(i, 1)
    End If
Next

Columns(3).RemoveDuplicates Columns:=1
'Начало говнокода (или уже середина?)
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
    If Cells(i, 1) = "" Then
        For Z = 2 To Cells(Rows.Count, 3).End(xlUp).Row
            If Cells(Z, 3) Like Cells(i, 2) Then
            Cells(Z, mytrigger + 3) = v & o
            End If
        Next
    ElseIf Cells(i, 1) <> "" And Cells(i + 1, 1) <> "" Then
        o = ""
        v = Cells(i, 1)
        Cells(1, mytrigger + 4) = v
        mytrigger = mytrigger + 1
    ElseIf Cells(i, 1) = "Да" Or Cells(i, 1) = "Нет" Then
        o = Cells(i, 1)
    ElseIf Cells(i, 1) <> "" Then
        v = Cells(i, 1)
        o = ""
        Cells(1, mytrigger + 4) = v
        mytrigger = mytrigger + 1
    End If
Next
End Sub
Изменено: Alias - 16.02.2018 15:07:36
 
 
 
#10
16.02.2018 15:14:31
На первый взгляд по моему мнению удобней использовать
Код
Select Сase 
...... 
End Select
вместо
Код
If Then 
......
End If
. Да и в массив я бы забрал а не на листе все делал.
Изменено: Nordheim - 16.02.2018 15:15:30
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#11
19.02.2018 06:07:59
Да, тоже подумал на счет кейса, но по привычке сделал if.
А сам подход к решению нормальный? Мне почему-то казалось, что шквал критики будет именно на сам подход, что есть какие-то стандартные методы.
 
 
 
#12
19.02.2018 07:01:28
формулами
Неизлечимых болезней нет, есть неизлечимые люди.
 
 
 
#13
19.02.2018 11:01:42
Alias, нормально у Вас все к кодом)
 
 
 
#14
19.02.2018 11:54:05
Цитата
Anchoret написал:
Alias , нормально у Вас все к кодом)
Вот этот код
Цитата
Alias написал:
If myArr(i, 1) Like "*амилия*" Then
При реальных фамилиях работать не будет.
Неизлечимых болезней нет, есть неизлечимые люди.
 
 
 
#15
19.02.2018 12:17:34
Цитата
TheBestOfTheBest написал:
При реальных фамилиях работать не будет.
Да) Нужно:
Код
If Len(MyArr(i,1))>0 then
 
 
 
Страницы: 1
Наверх