Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удалить все одинаковые символы, в каждой позиции в каждой ячейки по столбцу (Mask Alignment)
 
#1
18.11.2023 11:56:16
Добрый день! Помогите пожалуйста выполнить следующее действие: в каждой ячейке одного столбца, поочередно сравнить каждый первый (второй, третий и тд.) символы и если во всех ячейках один и тот-же символ, то удалить его.
Например, имеем две ячейки:
A1 "Мама мыла раму"
A2 "Мама пила ром-"
Остаться должно:
A1 "мыау"
A2 "пио-"
Наверное лучше макрос, которым можно было бы выделить несколько столбцов и он бы по каждому столбцу выполнил аналогичные действия.
Пример прикрепляю. Это нужно для уменьшения массива информации для построения филогенетических деревьев. Убираем все одинаковое, оставляем все отличающееся между последовательностями.
"Да не оскудеет рука дающего".  Евангелие от Матфея, глава 5, стих 7.
 
 
 
#2
18.11.2023 14:41:01

dim284 Здравствуйте Над скоростью не думал. Первый алгоритм, что пришел в голову написал.

Код
Sub enstaralfdh()
Dim Arr1(), Arr2() As String, Rg1 As Range, kCel&, kSim&, Str1$, StrVih$, i&, j&
Dim col1 As New Collection, Col2 As New Collection
Set Rg1 = ThisWorkbook.Worksheets("Лист1").Range("A2:A5")
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
Str1 = String(1, vbNullChar)
    For j = 1 To kSim
        For i = 1 To kCel
            Str1 = VBA.Mid(Arr1(i, 1), j, 1)
            On Error Resume Next
            col1.Add 0, Str1
            On Error GoTo 0
        Next
If col1.Count <> 1 Then Col2.Add j
Set col1 = New Collection
    Next
StrVih = String(Col2.Count, vbNullChar)
ReDim Arr2(1 To kCel, 1 To 1)
    For j = 1 To kCel
        For i = 1 To Col2.Count
        Mid(StrVih, i, 1) = VBA.Mid(Arr1(j, 1), Col2(i), 1)
        Next
    Arr2(j, 1) = StrVih
    Next
Rg1.Parent.Range("A13").Resize(kCel, 1) = Arr2
End Sub
Изменено: Евгений Смирнов - 18.11.2023 14:45:57
 
 
 
#3
18.11.2023 15:14:24
Евгений Смирнов, здравствуйте! Спасибо за ответ, но у меня ошибка выскакиевает, скриншот прикладываю.
А можно диапозон не в коде задавать, а либо по выделенному диапозону, либо после вызова макроса выделять диапозон?

А если вставить в модуль этой книги то работает. Наверное надо здесь что-то переделать:
Set Rg1 = ThisWorkbook.Worksheets("Лист1").Range("A2:A5")
Изменено: dim284 - 18.11.2023 15:20:41
 
 
 
#4
18.11.2023 16:12:46
Значит название листа не такое. По простому замените эту строку на
Код
Set Rg1 = Selection

Или вы это  в надстройку запихнули. С этой строкой должно работать по выделению. Макрос для одного столбца. Ячейка выгрузки A13 предпоследняя строка, если надо другую измените.

Изменено: Евгений Смирнов - 18.11.2023 16:29:39
 
 
 
#5
18.11.2023 17:13:45
С диалоговыми окнами
Код
Sub enstaralfd()
Dim Arr1(), Arr2() As String, Rg1 As Range, kCel&, kSim&, Str1$, StrVih$, i&, j&, DefaultRg$
Dim col1 As New Collection, Col2 As New Collection
DefaultRg = "A2:A5"
On Error GoTo Canceled
Set Rg1 = Application.InputBox("Диапазон из одного столбца", "Выберите диапазон ячеек", DefaultRg, , , , , 8)
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
Str1 = String(1, vbNullChar)
    For j = 1 To kSim
        For i = 1 To kCel
            Str1 = VBA.Mid(Arr1(i, 1), j, 1)
            On Error Resume Next
            col1.Add 0, Str1
            On Error GoTo 0
        Next
If col1.Count <> 1 Then Col2.Add j
Set col1 = New Collection
    Next
StrVih = String(Col2.Count, vbNullChar)
ReDim Arr2(1 To kCel, 1 To 1)
    For j = 1 To kCel
        For i = 1 To Col2.Count
        Mid(StrVih, i, 1) = VBA.Mid(Arr1(j, 1), Col2(i), 1)
        Next
    Arr2(j, 1) = StrVih
    Next
DefaultRg = "E1"
On Error GoTo Canceled
Set Rg1 = Application.InputBox("", "Выберите ячейку куда вставить", DefaultRg, , , , , 8)
Rg1.Resize(kCel) = Arr2
Canceled:
End Sub
Изменено: Евгений Смирнов - 18.11.2023 17:14:25
 
 
 
#6
18.11.2023 17:20:48
В целом работает, но на таком велике я не уеду. Можно по просьбе рабочего класса, выгрузку сделать в теже самые ячейки: например 100 ячеек в столбце, 100 и меняем на новые данные. И можно добавить ещё столбцы, количество ячеек в каждом столбце будет одинаковое.
-------------------------------------
Ну красота! Ещё бы пару сотню столбцов
-------------------------------------
Прикрепляю другой пример, чуть больше, но ближе к жизни.
Изменено: dim284 - 18.11.2023 17:29:53
 
 
 
#7
18.11.2023 17:31:01
dim284 Вы скажите как вам удобнее. Выгрузить в те же ячейки или добавить столбец для выгрузки. Я ведь за вас это не решу. Если добавлять столбец до или после столбца с данными.
Первое диалоговое окно надо или по Select будем работать.
 
 
 
#8
18.11.2023 18:05:15
Евгений, давайте в теже ячейки, а то файл тяжеловатый становиться, лучше заменить исходные данные. Как однажды справедливо заметил doober, лучше оставить первое диалоговое окно, в противном случае стороннему человеку не понятно почему макрос не работает.
 
 
 
#9
18.11.2023 18:32:20
В строковой переменной DefaultRg указан диапазон по умолчанию, который будет отображаться в диалоговом окне подправите как надо.
Код
Sub enstaral21()
Dim Arr1(), Arr2() As String, Rg1 As Range, kCel&, kSim&, Str1$, StrVih$, i&, j&, DefaultRg$
Dim col1 As New Collection, Col2 As New Collection
DefaultRg = "E2:E364"
On Error GoTo Canceled
Set Rg1 = Application.InputBox("Диапазон из одного столбца", "Выберите диапазон ячеек", DefaultRg, , , , , 8)
If Rg1.Columns.Count > 1 Then MsgBox "Вы выбрали не один столбец": Exit Sub
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
Str1 = String(1, vbNullChar)
    For j = 1 To kSim
        For i = 1 To kCel
            Str1 = VBA.Mid(Arr1(i, 1), j, 1)
            On Error Resume Next
            col1.Add 0, Str1
            On Error GoTo 0
        Next
If col1.Count <> 1 Then Col2.Add j
Set col1 = New Collection
    Next
StrVih = String(Col2.Count, vbNullChar)
ReDim Arr2(1 To kCel, 1 To 1)
    For j = 1 To kCel
        For i = 1 To Col2.Count
        Mid(StrVih, i, 1) = VBA.Mid(Arr1(j, 1), Col2(i), 1)
        Next
    Arr2(j, 1) = StrVih
    Next
Rg1 = Arr2
Canceled:
End Sub
 
 
 
#10
18.11.2023 19:25:34
Макрос отлично работает, спасибо Евгений! Но все же, побуду занудой, можно сделать так, чтобы его можно было применить к нескольким столбцам сразу? Выделил например диапозон B2:XJ364 и нажал ОК. Макрос будет более универсальный.
 
 
 
#11
18.11.2023 20:13:12
dim284 Можно конечно и для нескольких столбцов. Попробовал другой вариант проверки символов раза в 3 быстрее получается чем коллекцией. Сегодня уже пора отдыхать. Завтра попробуем.
 
 
 
#12
19.11.2023 08:58:56

dim284 Здравствуйте. Изменил проверку символов, так шустрее получается, чем проверять коллекцией. Добавил цикл для нескольких столбцов. Вроде работает проверяйте.

Код
Sub enstaralfdh1()
Dim Arr1(), Arr2() As String, Rg1 As Range, kCel&, kSim&, kSt%, Str1$, StrVih$, i&, j&, st%
Dim col1 As New Collection, Fl As Boolean, DefRg$
DefRg = "E2:E364"
On Error GoTo Canceled
Set Rg1 = Application.InputBox("", "Выберите диапазон ячеек", DefRg, , , , , 8)
Arr1 = Rg1.Value
kCel = UBound(Arr1, 1)
kSt = UBound(Arr1, 2)
ReDim Arr2(1 To kCel, 1 To kSt)
Str1 = String(1, vbNullChar)
For st = 1 To kSt
kSim = VBA.Len(Arr1(1, st))
    For j = 1 To kSim
    Str1 = VBA.Mid(Arr1(1, st), j, 1)
        For i = 2 To kCel
    If Str1 <> VBA.Mid(Arr1(i, st), j, 1) Then Fl = True: Exit For
        Next i
    If Fl Then col1.Add j: Fl = False
    Next j
StrVih = String(col1.Count, vbNullChar)
    For j = 1 To kCel
        For i = 1 To col1.Count
        Mid(StrVih, i, 1) = VBA.Mid(Arr1(j, st), col1(i), 1)
        Next i
    Arr2(j, st) = StrVih
    Next j
    Set col1 = New Collection
Next st
Rg1 = Arr2
Canceled:
End Sub
 
 
 
#13
19.11.2023 11:15:57
Евгений, спасибо огромное! Все очень круто работает. Постараюсь в ближайшее вермя пост для раздела Курилка написать. Кому-то будет полезно, кому-то, надеюсь, просто интересно. Все получилось! Дайте пару часов  8)  
 
 
 
#14
20.11.2023 11:41:43
dim284, здравствуйте
    Это почти то же самое, что создание строки из самых повторяющихся символов других строк, только быстрее и проще. Сейчас нет времени примотать решение оттуда. Возможно, позже …
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
Страницы: 1
Наверх