Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Просмотр столбца и разбивка результата на два столбика
 
#1
17.12.2014 20:02:17
Доброго времени суток!
Есть проблемка - требуется решение.
После поиска некоторых результатов, в столбик согласно поиску выводятся значения, пример: Qзак.=67т.м3/сут или Qзак.=138. Весь поиск происходит с помощью макроса.
Помогите написать макрос, чтобы он разбивал данный вывод данных на два столбика, в один выводил: Qзак., а во-второй числовое значение - в первом случае 67, во-втором случае 138.
Файл с наглядным примером загрузил.
 
 
 
#2
17.12.2014 20:31:33
Зачем писать другой макрос, когда скорее всего можно немного подправить уже работающий?
 
 
 
#3
17.12.2014 20:45:24
Я в этом деле ничего не понимаю. Мне макрос сделали
 
 
 
#4
17.12.2014 20:46:59
Ну так покажите этот макрос.
 
 
 
#5
17.12.2014 21:03:27
Код
Sub vvv_1() 'k61
Dim mmm() 'âõîäíîé
'óáðàòü ñòîëá 23!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets("Áàçà êîíòðîëüíûõ çàìåðîâ")
r = .Cells(.Rows.Count, 4).End(xlUp).Row
With .Range(.Cells(7, 1), .Cells(r, 23))
.Sort _
Key1:=.Cells(7, 4), Order1:=xlAscending, _
Key2:=.Cells(7, 5), Order2:=xlAscending, _
Key3:=.Cells(7, 6), Order3:=xlDescending
mmm = .Value
End With: End With
For i = 1 To r - 6                      '100
  If i <> 1 Then                        '101
    If mmm(i, 4) = mmm(i - 1, 4) Then   '102
      If mmm(i, 5) = mmm(i - 1, 5) Then '103
      mmm(i, 6) = ""
      End If                            '103
    End If                              '102
  End If                                '101
Next i                                  '100

With Sheets("Òåêóùèå")
r1 = .Cells(.Rows.Count, 4).End(xlUp).Row
If r1 > 14 Then                         '104
With .Range(.Cells(16, 1), .Cells(r1, 23)) 'áåç øàïêè
.Cells.ClearContents
End With
End If                                  '104
With .Cells(16, 1).Resize(r - 6, 23)
.Value = mmm
  With .Resize(r, 23).Offset(-1, 0)
  .Columns(6).AutoFilter 1, "="
  End With
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Columns(6).AutoFilter
End With
.Select
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 
Beep
End Sub
 
 
 
#6
17.12.2014 21:09:02
Код
Sub Qgaz()
Application.ScreenUpdating = False
For Each c In Selection
    If IsNumeric(c) Then c.Offset(, 1) = c Else c.Offset(, 1) = Split(c, "=")(0): c.Offset(, 2) = Split(c, "=")(1)
Next
Application.ScreenUpdating = True
End Sub 

Sub Qgaz2()
Application.ScreenUpdating = False
Dim arr()
arr = Selection
ReDim Preserve arr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr())
    If IsNumeric(arr(i, 1)) Then arr(i, 1) = arr(i, 1) Else arr(i, 2) = Split(arr(i, 1), "=")(1): arr(i, 1) = Split(arr(i, 1), "=")(0)
Next i
[c2].Resize(UBound(arr), UBound(arr, 2)) = arr
Application.ScreenUpdating = True
End Sub
 
 
 
#7
17.12.2014 21:17:07
Это куда поставить или дописать???
 
 
 
#8
17.12.2014 21:17:35
Примазываюсь к моде  :D
Код
Function Q(cell)
Dim aa
    With CreateObject("VBScript.RegExp")
        .Global = True: .IgnoreCase = True: .Pattern = "^(Q.+)=(\d+,?\d+?)"
        If .test(cell) Then
            Set aa = .Execute(cell)
            Q = Array(aa.Item(0).submatches(0), aa.Item(0).submatches(1))
        Else
            Q = ""
        End If
    End With
End Function
 
 
 
#9
17.12.2014 21:21:30
Большое спасибо ребята. Очень вам благодарен за помощь.
 
 
 
#10
18.12.2014 06:03:46
RAN, Извините поторопился. Можно данный макрос сделать, чтоб запускался с сочетания клавиш? Использовался для столбика Q, в столбик Р записывалось Qзак, а в столбик Q - числовое значение. И не создавалось новых столбиков. А так в целом просто всё отлично.
Изменено: GeologYuriy - 18.12.2014 06:04:36
 
 
 
#11
19.12.2014 16:55:24
GeologYuriy,это функция а не процедура, что бы запускать по  кнопке. Функция не создает новых столбцов.
Работать надо не 12 часов, а головой.
 
 
 
#12
19.12.2014 17:08:49
Но функцию можно написать массивной, чтоб выводила результат сразу в 2 соседние ячейки.
P,S. ЧТо впрочем у RAN и реализовано - не смотрел файл и код :(
Изменено: Hugo - 19.12.2014 17:10:41
 
 
 
#13
19.12.2014 19:57:37
Цитата
RAN пишет: Примазываюсь к моде
подумаю вслух про ваш паттерн: (работает  :)  )
Код
Sub test()
Dim a, arr, lr&, i&
lr = Cells(Rows.Count, 2).End(xlUp).Row
arr = ThisWorkbook.Sheets(1).Range("B2:B" & lr).Value

ReDim a(1 To UBound(arr), 1 To 2)
    With CreateObject("VBScript.RegExp")
     .Global = True: .IgnoreCase = True: .Pattern = "^(Q.+)=(\d+,?\d+?)"   '  "^(Q.+)=(\d+(,?|.?)\d+?)" для моей системы с точками-разделителями дробных, иначе иногда теряет дробные части
     
    For i = 1 To UBound(arr)
     If .test(arr(i, 1)) Then
      a(i, 1) = .Execute(arr(i, 1)).Item(0).submatches(0)
      a(i, 2) = --(.Execute(arr(i, 1)).Item(0).submatches(1))
     Else: a(i, 1) = "": a(i, 2) = arr(i, 1)
     End If
    Next
    End With
[P2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub
надеюсь, ТС сам к кнопке привяжет...

Цитата
GeologYuriy пишет: Использовался для столбика Q
тогда замените в строке 4 столбец "B2:B" на "Q2:Q"
Изменено: JeyCi - 20.12.2014 12:40:25
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
Страницы: 1
Наверх