1

Тема: VBA: макрос-сортировщик для ms excel

Здравствуйте!
Помогите, пожалуйста написать макрос, который бы сортировал ячейки по их содержимому. Суть задачи такова: есть файл, в первом столбце которого много-много ячеек с наименованиями. Хотелось бы, чтобы макрос сканировал все непустые ячейки этого столбца (ну, или просто ячейки от первой до произвольной; или до 65535) и при совпадении хотя бы части содержимого с шаблоном (например, "гайка" или, лучше, "гайк*"), переносил всё содержимое ячейки в соседнюю (т.е. в ячейку соседнего столбца, имеющую тот же номер, что и исходная). Совсем здорово было бы, если бы макрос сканировал ячейки на совпадение с несколькими шаблонами, например "гайк*", "шуру*" и "гвозд*" и брал бы эти значения шаблонов из опредленных, специально предназначенных для этого, ячеек; а переносил не только в соседнюю ячейку, а в ячейку с заданным смещением (для каждого шаблона - свое смещение; гайки - в соседнюю, шурупы - в "через одну" и т.д.).
По идее, ничего сложного - пара-тройка циклов и стандартных функций excel, но я как начинаю читать man к этому делу, сразу засыпаю на полчаса минимум. Прямо чертовщина какая-то.
:-)
Помогите, пожалуйста.

2 (изменено: arcnik, 2011-12-28 16:28:50)

Re: VBA: макрос-сортировщик для ms excel

Sub Capmup()
Do
X3 = InputBox("Шаблон", "Сартир", "Болт")
For n = 1 To 500
If Mid(Range("A" & n), 1, Len(X3)) = X3 Then
Range("B" & n) = Range("A" & n)
End If
Next
a = MsgBox("Ищем еще что?", 5, "Сартир")
If a = 2 Then
Exit Do
End If
Loop
End Sub

3 (изменено: Dmitrii, 2012-01-04 01:16:45)

Re: VBA: макрос-сортировщик для ms excel

arcnik, этой задаче (судя по дате в заголовке) уже больше года. Думается, что автор уже получил желаемое решение.
Кстати, если мне не изменяет память, варианты решений были опубликованы и здесь, только, похоже, после серии чисток потерялись.
На тот случай, если они кому-то всё-таки нужны, опубликую их заново.

1. Вариант с макросом.

Option Compare Text

Sub Example()
Dim objRange As Range, objTemplates As Name, objCell As Range
Dim intShList As Integer, intBaseBar As Integer, strTemplates As String
Dim strTemp As String, arrTemp

intShList = 1 'Порядковый номер листа (в книге) с обрабатываемым списком.
intBaseBar = 1 'Порядковый номер столбца (на листе) с обрабатываемым списком.
strTemplates = "Шаблоны" 'Имя диапазона ячеек с шаблонами наименований изделий
                         '(должен быть расположен в одном столбце или одной строке).
On Error Resume Next
Set objTemplates = ThisWorkbook.Names(strTemplates)
If Err.Number = 0 Then
    If UBound(objTemplates.RefersToRange.Value, 2) > 1 Then
        If UBound(objTemplates.RefersToRange.Value, 1) = 1 Then
            arrTemp = Application.Transpose(Application.Transpose(objTemplates.RefersToRange))
        Else
            MsgBox "Список шаблонов должен быть задан столбцом или строкой.", vbCritical
        End If
    Else
        arrTemp = Application.Transpose(objTemplates.RefersToRange)
    End If
    If IsArray(arrTemp) Then
        With Worksheets(intShList)
            '--- Предварительное удаление текстовых значений из ячеек,
            'расположенных в столбцах правее столбца с обрабатываемым списком
            '(не обязательное действие).
            Set objRange = .Range(Columns(intBaseBar + 1), Columns(256)).Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
            If Err.Number = 0 Then
                objRange.ClearContents
            Else
                Err.Clear
            End If
            '------
            Set objRange = .Columns(intBaseBar).Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
            If Err.Number = 0 Then
                For Each objCell In objRange
                    strTemp = objCell.Value
                    For i = LBound(arrTemp) To UBound(arrTemp)
                        If InStr(strTemp, arrTemp(i)) > 0 Then
                            .Cells(objCell.Row, intBaseBar + i).Value = strTemp
                            Exit For
                        End If
                    Next
                Next
            Else
                MsgBox "В заданном диапазоне подходящих ячеек не найдено.", vbCritical
                Err.Clear
            End If
            Erase arrTemp
            Set objRange = Nothing
            '--- Автонастройка ширины колонок, содержащих какие-либо данные
            '(не обязательное действие).
            .UsedRange.Columns.AutoFit
            '------
        End With
        MsgBox "Готово.", vbInformation
    End If
Else
    MsgBox "Именованый диапазон " & UCase(strTemplates) & " не найден.", vbCritical
    Err.Clear
End If
Set objTemplates = Nothing
End Sub

2. Варианты с формулами рабочих листов можно скачать здесь: http://fayloobmennik.net/492785

4

Re: VBA: макрос-сортировщик для ms excel

OFF:

Dmitrii пишет:

Кстати, если мне не изменяет память, варианты решений были опубликованы и здесь, только, похоже, после серии чисток потерялись.

После чистки особенно интересно стали выглядеть темы, состоящие из одних ответов . Как монолог какой-то.