Страницы: 1
RSS
Доделка макроса на исполнение другой функции
 
Здравствуйте.

Возникла потребность доработать данный макрос.

Он по исходнику со значениями ищет в искомом столбце совпадения и помечает их желтым.
Так вот нужно последние действие заменить не на пометку желтым а на вырезание (вместе с ячейкой, что бы пустая ячейка не оставалась посреди искомого столбца) и перенос в другой столбец(к примеру в Е5)


В столбец в который он будет переносить будут еще другие данные, и если они там есть, то нужно что бы он ставил найденные данные в конце после существующих а не ставил поверх них или удалял их.

Так вот главное для меня это скорость работы макроса, помогите правильно все это прописать так, что бы все работало правильно и быстро. Сам не знаю как такое прописать адекватно. Написал пару вариантов но они ужасные)

Может что то непонятно объяснил, в примере нагляднее все расписал.

P.S данный макрос почти никакого отношения не имеет к другой недавно созданной теме, они предназначены для разных вещей и выполняют разные задачи, и в них так же разные проблемы.

Заранее благодарю!
 
Попробуйте так..
Код
Sub tt()
    Dim r As Range
    If Not Intersect(ActiveCell, [Словарь]) Is Nothing Then 'ячейка словаря
        Set r = [Искомое].Find(ActiveCell, , , xlPart)
        If Not r Is Nothing Then
            r.Copy [Перенос].Cells([Перенос].Count).End(xlUp).Offset(1)
            r.Delete shift:=xlUp
        End If
    End If
End Sub
Изменено: Маугли - 06.04.2019 05:30:11
 
Маугли, немного не понял смысл вашего примера, 1. вы закомментили  весь макрос с необходимым функционалом. 2. я пока не понимаю как он работает (ничего не происходит) и для чего служит кнопка?)
 
Разве этот макрос tt  не работает , как вы сказали?

Выбираете из словаря -щелкаете кнопку. Не так ?
Изменено: Маугли - 04.04.2019 12:19:24
 
Маугли, нет я описывал совсем по другому. и Ваш макрос работает не так как нужно.
1. нужно переделать только маленькую часть в конце моего макроса и все, не нужно делать новый
2. ваш макрос не так работает как мой
3. выделение диапазона не нужно, он статичен.
Ровным счетом в моем макросе нужно только изменить последнюю строку отвечающую за пометку цветом и заменить ее на код который просто удалит из искомого столбца и перенесет в другой как я и описал ранее.

Велосипед не нужно придумывать, только покажите как эту строку заменить, что бы она делала вышеописанное.
Код
If arr(li, 2) = "x" Then Cells(li, 2).Interior.Color = 65535
Изменено: Fsociety_ - 04.04.2019 15:24:45
 
Цитата
Fsociety_ написал:
в моем макросе нужно только изменить последнюю строку
Иногда лучше начать всё с самого начала, часто трудно улучшить чужою кодировку и проще создать свою собственную.
Пожалуйста попробуйте:

Если должно быть с сортировкой, можно сделать таким образом:
Код
Option Explicit

Sub Del_Array_SubStr()
    Dim t!: t = Timer
    Dim lLastRowB As Long, lLastRowC As Long, li As Long, lr As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Application.EnableEvents = False
    
    With Sheets("Лист1")
        lLastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
        lLastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
        
        For lr = 5 To lLastRowC
            For li = 5 To lLastRowB
                If LCase(.Range("B" & li).Value) Like "*" & LCase(.Range("C" & lr).Value) & "*" Then
                    .Range("D" & .Rows.Count).End(xlUp).Offset(1, 0).Value = .Range("B" & li).Value
                    .Range("B" & li).Value = ""
                End If
            Next
        Next
        
        .Range("B4:B" & lLastRowB).Sort .Range("B4"), Header:=xlYes
        .Range("D4:D" & .Cells(.Rows.Count, "D").End(xlUp).Row).Sort .Range("D4"), Header:=xlYes
    End With
    
    Application.EnableEvents = True
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
konets: Debug.Print Format(Timer - t, "0.0000")
End Sub
Если без сортировки, то например:
Код
Option Explicit

Sub Del_Array_SubStr()
    Dim t!: t = Timer
    Dim i As Long, j As Long, indB As Long, indC As Long
    Dim arrB(), arrC(), arrD(), pos
    
    With Application
        .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False
        
        With .ThisWorkbook.Sheets("Лист1")
            arrB = .Range("B5:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value: indB = UBound(arrB, 1)
            arrC = .Range("C5:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value: indC = UBound(arrC, 1)
            
            For i = 1 To indC
                pos = Application.Match("*" & arrC(i, 1) & "*", arrB, 0)
                If Not IsError(pos) Then
                    j = j + 1: ReDim Preserve arrD(1 To j): arrD(j) = arrB(pos, 1)
                    arrB(pos, 1) = ""
                End If
            Next
            
            If j = 0 Then MsgBox "Нет совпадений": GoTo konets
            Erase arrC: ReDim arrC(1 To indB - j, 1 To 1): j = 0
            
            For i = 1 To indB
                If arrB(i, 1) <> "" Then j = j + 1: arrC(j, 1) = arrB(i, 1)
            Next
            
            .Range("B5:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).ClearContents
            .Range("B5").Resize(j, 1).Value = arrC
            .Range("D" & .Cells(.Rows.Count, "D").End(xlUp).Row + 1).Resize(UBound(arrD), 1).Value = Application.Transpose(arrD)
            Erase arrB: Erase arrC: Erase arrD
        End With
        
        .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True
    End With
    
konets: Debug.Print Format(Timer - t, "0.0000")
End Sub
 
ocet p, протестировал ваши варианты уже примерно то что нужно, но все равно переделка верх ногами, к примеру в вашем макросе я не могу менять параметры точности поиска соответствий как в своем.
Этими строками:
Код
            'If " " & LCase(arr(li, 1)) & " " Like "*" & LCase(sSubStr) & "*" Then '- совсем не точное
            If " " & LCase(arr(li, 1)) & " " Like "* " & LCase(sSubStr) & "*" Then '- не очень точное
            'If " " & LCase(arr(li, 1)) & " " Like "* " & LCase(sSubStr) & " *" Then '- точное
            'If " " & LCase(arr(li, 1)) & " " Like " " & LCase(sSubStr) & " " Then '- Идеальное :-)

в вашем варианте я пока не разобрался как это сделать. Я так понял вы брали за основу этот код и в нем так же должно звездачками регулироватся точность, но что то не работает)
 

Я не понимаю схем этой вашей "точности", ведь "*" = "* " = " *", звездочка "*" заменяет любую строку символов или ни одной, если она не существует, поэтому нет необходимости писать "* " или " *", так как это то же самое, что и "*". В каких словосочетаниях вы это используете, приведите пример.

 
Цитата
ocet p написал:
"* " или " *", так как это то же самое, что и "*"
А Вы нажмите Ctrl+H и проверьте это утверждение )
 
ocet p, ну этр абсолютно не так. Разница большая. например 1 вариант точности из моего кода ищет примерно как ваш.(ваш код находит жаже по одной букве слова). 2 вариант уже жестче и ищет совпадения по половине слова к примеру. 3 вариант уже 80% совпадения ищет и т.д.. Это я как пример привел. Можете попробовать в моем примере изначальном, там все для этого есть.
Поэтому я и акцентировал внимание на то что бы сам код оставить как есть а изменить в нем нужно только последнюю строку которая делает нужные ячейки желтыми. И все.
 
Like Operator
Characters in pattern Matches in string
=========================================
?   Any single character
*   Zero or more characters
#   Any single digit (0–9)
[charlist]  Any single character in charlist
[!charlist]  Any single character not in charlist


В каких словосочетаниях вы это используете ?
Приведите примеры.
 
ocet p, я сейчас детальнее потестировал ваш код, ну вроде работает как нужно, как старый, но это только в неточном соответствие, к примеру мне нужно выставить 100% совпадение или 80% совпадение с искомым словом, в моем варианте я могу это сделать. В вашем я пока не понимаю как это реализовано. Вот к примеру результат поиска вашего кода:


Желтым помечены те которые должны переместится при 100% точности.
Поставьте на подобие слова в моем коде, и меняйте 4 варианта точности, с одного искомого слова он будет выдавать разные результаты + там комментарии в коде прописаны какое точно и какое не точное соответствие.
Страницы: 1
Наверх