Страницы: 1
RSS
Фикс Макроса аналог индекс+поискпоз через ; в одну ячейку без повторений, Макрос, Excel 2013, немного пофиксить
 

UDP вопрос решён)

Очень интересно было бы услышать мнение-совет-вашу версию кода...

Осмотрел уже все, что смог найти в инете... написал свой вариант, но выдает ошибку где-то

СПАСИБО!!!

Вот пытаюсь в который день создать код макроса для Visual Basic в Эксель 2013 года для заполнения знаков вопроса согласно примеру необходимого результата.

Основная проблема - строк 10000, неудобно делать это через связку сцепить+индекс+поискпоз с разделителем ;

Да ещё и важно избежать повторения уже вставленных строк.

Дано: 2 таблицы. Одна заполненная, на листе 1 , вторую на листе 2 нужно заполнить с помощью программируемого кода через макрос. Даю пример, по которому нужно проверить, что все работает. Все объединил на третьем листе, чтобы было удобно понять, что к чему.

Алгоритм действий:

1 Найти в таблице 1 первое совпадение сырья в столбце E

2 Вставить название подразделения из первого столбца таблицы 1. Вставить текстовый разделитель "; "

4 Найти в таблице 1 следующее совпадение сырья в столбце E

5 Если совпадение найдено, вставить название подразделения из первого столбца таблицы 1 и текстовый разделитель ";", только если оно ещё НЕ БЫЛО вставлено (избежать повторения).

6 Если совпадений больше не найдено, а последний символ ";", то удалить ";"

7 Если совпадений не было в принципе, то вставить текст "-"

Код макроса вот такой:

Код
Sub ЗаполнитьПодразделения()

'Создаем объекты

Dim wb As Workbook

Dim wsSource As Worksheet

Dim wsResult As Worksheet

Dim rngSource As Range

Dim rngResult As Range

Dim lastRow As Long

Dim lastCol As Long

Dim strRaw As String

Dim arrData() As String

Dim strSeparator As String

'Инициализируем объекты

Set wb = ThisWorkbook

Set wsSource = wb.Sheets("Лист1")

Set wsResult = wb.Sheets("Лист2")

'Определяем последний ряд и последний заполненный столбец в таблице 1

lastRow = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row

lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

'Берем данные из таблицы 1

Set rngSource = wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRow, lastCol))

arrData = rngSource.Value

'Ищем совпадения в таблице 2

Set rngResult = wsResult.Range(wsResult.Cells(2, 3), wsResult.Cells(lastRow, 3))

For i = 1 To lastRow

    strRaw = rngResult.Cells(i, 1).Value 'текущее сырье

    For j = 1 To UBound(arrData, 1)

        If arrData(j, 2) = strRaw Then 'совпадение найдено, добавляем подразделение

            rngResult.Cells(i, 3).Value = rngResult.Cells(i, 3).Value & arrData(j, 1) & "; "

        End If

    Next j

    If rngResult.Cells(i, 3).Value Like "*; " Then

        rngResult.Cells(i, 3).Value = Left(rngResult.Cells(i, 3).Value, Len(rngResult.Cells(i, 3).Value) - 2)

    ElseIf rngResult.Cells(i, 3).Value = "" Then

        rngResult.Cells(i, 3).Value = "-"

    End If

Next i

'Сообщаем о завершении

MsgBox "Заполнение подразделений завершено!", vbInformation, "Успех:)"

End Sub
Изменено: rodiono - 06.06.2024 11:59:05
 
1. Не нужно писать через строку - воспринимается плохо
2. Код следует оформлять тегом. Ищите на панели значок <...>
3. Для чего вы продублировали в сообщении таблицы из файла? Они только отвлекают.
Исправьте свое стартовое сообщение
0. Эта тема точно должна быть в Курилке?
Согласие есть продукт при полном непротивлении сторон
 
rodiono,
посмотрите concat от ZVI (не уверен, что во вложении последняя версия)
Изменено: evgeniygeo - 06.06.2024 07:40:42
 
Добрый день!
Sanja, спасибо за уточнение правил, буду иметь в виду! :)
evgeniygeo, спасибо, тоже интересный вариант, попробую его тоже, может, тогда быстрее работать будет
Прикрепляю свою заработавшую версию кода, вдруг кому пригодится)
Код
Sub Найтисовпадения()
    Dim lastRowA As Long
    Dim lastRowF As Long
    Dim i As Long
    Dim j As Long
    Dim result As String
    
    Dim col As New Collection
    
    lastRowA = Sheets("Лист1").Cells(Rows.Count, "C").End(xlUp).Row
    lastRowF = Sheets("Лист2").Cells(Rows.Count, "A").End(xlUp).Row

   
    For i = 1 To lastRowF
        result = ""
        For j = 1 To lastRowA
            If Sheets("Лист2").Cells(i, "A").Value = Sheets("Лист1").Cells(j, "E").Value Then
                If result = "" Then
                    result = Sheets("Лист1").Cells(j, "C").Value
                Else
                    result = result & "; " & Sheets("Лист1").Cells(j, "C").Value
                End If
            End If
        Next j
        Sheets("Лист2").Cells(i, "C").Value = result
    Next i
     
    
    On Error Resume Next
    
    For Each cell In Selection
        Set col = Nothing
        sResult = ""
        arWords = Split(WorksheetFunction.Trim(cell.Value), "; ")
        For i = LBound(arWords) To UBound(arWords)
            Err.Clear
            col.Add arWords(i), arWords(i)
            If Err.Number = 0 Then sResult = sResult & " " & arWords(i)
        Next i
        cell.Value = Trim(sResult)
    Next cell    
End Sub
Изменено: Sanja - 06.06.2024 14:56:14 (Про запись через строку проигнорировали?)
Страницы: 1
Наверх