Страницы: 1
RSS
Совместить два кода вместе: удаление слов и сортировку чисел в столбце
 
Здравствуйте, помогите совместить два макроса
или сделать так, чтобы выводил как в ячейке K9
Один код отвечает за удаление слов и сортировку чисел в столбце
в нем есть недостаток, он не удаляет последнее 1-865, т.е нужно доработать, чтобы код оставлял только числа, а с тире вовсе удалять
Код
Function yyy$(t$)
   Dim i%
For i = 1 To Len(t)
If Mid(t, i, 1) Like "[0-9]" Then s = s & Mid(t, i, 1)
Next
  yyy = Trim(s)
End Function
Sub Сорт()
[A:A].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlYes
   Dim i&, j&, x, t$
   x = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
     For i = 1 To UBound(x): t = x(i, 1)
        For j = 1 To Len(t)
         If Mid(t, j, 1) Like "[0-9]" Then s = s & Mid(t, j, 1)
       Next
        x(i, 1) = Trim(s): s = ""
     Next
   Range("A2").Resize(UBound(x), UBound(x, 2)).Value = x
   Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).NumberFormat = "0"
End Sub

Код второго макроса расставляет числа в столбец, сам код прописан внутри листа
Код
Option Explicit

Sub qwert()
Dim rz, ubr, dob, diap, m, t, i, s, j, ЗК, pr As Boolean
Set rz = CreateObject("Scripting.Dictionary")
With Лист1
    Set ubr = Get_Spis(.Range("A1").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row).Value)
    Set dob = Get_Spis(.Range("B1").Resize(.Cells(.Rows.Count, 2).End(xlUp).Row).Value)
    Set diap = Get_Spis(.Range("C1").Resize(.Cells(.Rows.Count, 3).End(xlUp).Row).Value)
    For Each t In ubr.keys
        If diap.exists(t) Then diap.Remove (t)
    Next t
    For Each t In dob.keys: diap(t) = 0: Next t
    .[g1].Resize(diap.Count) = Application.Transpose(diap.keys)
    .Columns("G:G").Sort Key1:=Range("G" & diap.Count)
    ubr = .Range("g1:g" & diap.Count + 1).Value
    .Range("g1:g" & diap.Count + 1).ClearContents
    .Range("D2:D10000").ClearContents

    For i = 1 To UBound(ubr)
        t = ubr(i, 1)
        If Len(j) = 0 Then
            j = t: s = t
        Else
            If t - j = 1 Then
                j = t: pr = True
            Else
                rz(IIf(pr, s & "-" & j, s)) = 0: j = t: s = t: pr = False
            End If
        End If
    Next i
    
    .Range("D2:D" & rz.Count + 1) = Application.Transpose(rz.keys)
End With
    MsgBox diap.Count, , ""
End Sub

Private Function Get_Spis(s)
Dim N, k, u, i, j
Dim os: Set os = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(s)
    u = Split(s(i, 1), "-"): N = CDbl(u(0)): k = CDbl(u(UBound(u)))
    For j = N To k: os(j) = 0: Next j
Next i
Set Get_Spis = os
End Function



Изменено: next777pro - 22.06.2016 13:09:12
 
В общем случае вызов двух макросов можно сделать так:
Код
Sub Main() 'Главный запускаемый макрос
    Call Макрос1
    Call Макрос2
    'Очерёдность поставьте сами
End Sub
Или в нужном месте первого макроса напишите строку вызова второго:
Код
    Call Макрос2
 
Цитата
next777pro написал:
а с тире вовсе удалять
Код
If Mid(t, i, 1) Like "[0-9]"  and not Mid(t, i, 1) Like "*-*" Then s = s & Mid(t, i, 1)

но это не точно, нужно разбираться в коде, но как вектор для размышление
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
Юрий М написал:
вызов двух макросов
благодарю и большое спасибо, очень помогло
а недостаток первого макроса все еще не решен , убрать числа с тире в столбце A  здесь стоит 1-865, но может и быть и другое число ..-.. если есть с тире, то убрать
Изменено: next777pro - 22.06.2016 14:07:02
 
Цитата
Фродо написал:
нужно разбираться в коде
не помогло
 
Цитата
next777pro написал:
не помогло
ну вот в базе оно примерно так, если я не ошибаюсь
Код
Sub r()
If ActiveCell Like "*-*" Then ActiveCell = ""
End Sub
Изменено: Фродо - 22.06.2016 14:19:19
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
next777pro написал:
убрать числа с тире
Код
ActiveCell = Replace(ActiveCell, "-", "")
 
Юрий М, я как понял ему все число надо убрать а не тире)))
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
Фродо написал:
ну вот в базе оно примерно так, если я не ошибаюсь
1- 865 как было 1865 так и осталось
1865
может я чет не так сделал
Код
Function yyy$(t$)
   Dim i%
For i = 1 To Len(t)
If Mid(t, i, 1) Like "[0-9]" And Not Mid(t, i, 1) Like "*-*" Then s = s & Mid(t, i, 1)
Next
  yyy = Trim(s)
End Function
Sub Сорт()
[A:A].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlYes
   Dim i&, j&, x, t$
   x = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
     For i = 1 To UBound(x): t = x(i, 1)
        For j = 1 To Len(t)
         If Mid(t, j, 1) Like "[0-9]" Then s = s & Mid(t, j, 1)
         If Переменная Like "*-*" Then Переменная = ""
       Next
        x(i, 1) = Trim(s): s = ""
     Next
   Range("A2").Resize(UBound(x), UBound(x, 2)).Value = x
   Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).NumberFormat = "0"
End Sub
Изменено: next777pro - 22.06.2016 14:20:30
 
Тогда #6 ))
 
Цитата
Юрий М написал:
Тогда #6 ))
не умею гадать)
 
Сообщение НОМЕР шесть.
 
next777pro,
6 пост поправил, более понятней сделал, его работу можете даже проверить как самостоятельным макросом,
Разбираться в вашем коде, мне не хочеться, если сами не сможете использовать то что я дал совет и Юрий М,
тогда подождите может другой участник разберется в вашем коде и внедрит эту функцию
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
Фродо написал:
убрать а не тире)))
тире и до этого убирал изначально) число с тире конечно надо
 
Цитата
next777pro написал:
тире и до этого убирал изначально) число с тире конечно надо
я лично не понял этой фразы.....
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
Фродо написал: понял этой фразы..
1-865 убрать целиком
 
next777pro, ну Вам же показали, как это сделать: см #6
 
Может это к делу не относится но для информации есть дифис , а есть тире, это разные знаки
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
Юрий М написал: ну Вам же показали
так работает
Код
Sub жал()
If ActiveCell Like "*-*" Then ActiveCell = ""
End Sub

а так пишет ошибка в формуле
Код
Sub r()
If ActiveCell Like "*-*" Then ActiveCell = ""
End Sub
Изменено: next777pro - 22.06.2016 15:49:35
 
И чем же эти два кода отличаются? И что за ошибка? И про какую формулу Вы говорите?
next777pro, ну нельзя же так: ошибка... А нам додумывать, что за сообщение?
 
Юрий М, next777pro,
название макроса видно пересекается с другим или с глобальными переменными
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
Фродо написал:
более понятней сделал, его работу
спасибо, сработал отдельно в выделенном, но код такой не пойдет
надо в столбце A
 
next777pro,
название теммы вообще о другом, и она раскрыта, надо завершать тут дискусию а то модераторы начнут ругаться
у меня простая версия Экселя, в ней нет кнопки "Прочитать мысли и сгенерировать файл пример"
 
Цитата
next777pro написал:
но код такой не пойдет надо в столбце A
Вот и покажите нам НЕБОЛЬШОЙ файл (строк на 10-15), где в столбце А вперемешку введите данные. Те, которые подлежат удалению, залейте жёлтым. Иначе мы "на пальцах" будем до позднего вечера пытаться узнать, что там за ошибка у Вас.
 
Цитата
Фродо написал: название теммы вообще о другом
Один код отвечает за удаление слов и сортировку чисел в столбце
в нем есть недостаток, он не удаляет последнее 1-865, т.е нужно доработать, чтобы код оставлял только числа, а с тире вовсе удалять

об этом написано
решено пока на 90 процентов
Изменено: next777pro - 22.06.2016 15:49:46
 
Фродо, прав: тема совсем о другом.
next777pro, относительно моего #24 - создайте новую тему.
 
Цитата
Юрий М написал:
относительно моего #24 - создайте новую тему.
И обновляйте страничку и читайте, прежде чем создавать сообщение.
 
Цитата
Юрий М написал: относительно моего #24
сделаем
Страницы: 1
Наверх