Страницы: 1
RSS
Не срабатывает макрос поиска по частичному совпадению
 
Помогите написать макрос.  
Нужно из вкладки СА перенести все совпадения (столбцы E, D)  по столбцу B во вкладку "упр(2)" со столбцом D (без последних трех символов) . Бывает по несколько совпадений. Во вкладке "упр(2)" в столбцах E и F как в итоге должно получиться.  
Изменено: enot7 - 28.03.2018 07:51:28
 
Цитата
Где ошибка в макросе не могу понять
В файле вообще нет макроса.
На листе СА в столбце А нет данных, а вы там пытаетесь найти усеченный артикул.
Почему начинаете цикл с i=12 ?
 
Kuzmich, в файле нет макроса, т.к. на разных компьютерах делался файл и разные офисы на компах, поэтому просто в ставила в текст.
А я вроде и не указываю столбец А, где вы увидели? Насчет цикла точно не могу ответить, этот макрос мне тут подсказали, только для другого документа. Я попыталась переделать, но не получается.
 
Цитата
А я вроде и не указываю столбец А, где вы увидели?
Вот здесь, например
Код
Set FoundCell = .Columns(1).Find(Articul, , xlValues, xlPart)
 
Kuzmich, к сожалению я в этом не понимаю, и поэтому обратилась сюда.  
 
enot7, код следует оформлять соответствующим тегом: ищите такую кнопку <...> и исправьте своё стартовое сообщение.
 
Юрий М, я изменила совсем стартовое сообщение, чтобы никого не путать.  
 
А теперь моё сообщение #6 выглядит вообще нелепо )
 
Юрий М, сорри) но надеюсь теперь мне помогут без переделок)  
 
Цитата
но надеюсь теперь мне помогут
Проверяйте, усеченные артикулы в столбце Е
Код
Sub Articul()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim Articul As String
Dim FAdr As String
Dim n As Integer
  iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
  Range("E5:G" & iLastRow).ClearContents
With CreateObject("scripting.dictionary"): .comparemode = 1
    n = 5
  For i = 5 To iLastRow
    If Not IsEmpty(Cells(i, "D")) Then
     Articul = Left(Cells(i, "D"), Len(Cells(i, "D")) - 3)
       If Not .exists(Articul) Then
          .Add Articul, 1
          Cells(n, 5) = Articul
          n = n + 1
        End If
    End If
  Next
End With
With Worksheets("СА")
  iLastRow = Cells(Rows.Count, "E").End(xlUp).Row
      n = 0
 For i = 5 To iLastRow
  Articul = Cells(i, "E")
   Set FoundCell = .Columns(2).Find(Articul, , xlValues, xlPart)
    If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        .Range(.Cells(FoundCell.Row, "E"), .Cells(FoundCell.Row, "F")).Copy Cells(i + n, "F")
       Set FoundCell = .Columns(2).Find(Articul, after:=FoundCell)
       n = n + 1
      Loop While FoundCell.Address <> FAdr
    End If
 Next
End With
End Sub
Удачи!
 
Kuzmich, да все правильно срабатывает, только при сопоставлении по третьему усеченному артикулу, строчки съехали на одну ниже,и напротив первой позиции (по третьему усеченному артик.) пусто.
 
Цитата
строчки съехали на одну ниже
Это не строчки съехали, а разделены группы по каждому усеченному артикулу
 
Kuzmich, по первым двум усеченным артикулам все правильно, а вот на третьем съехало, пример прикрепила
Страницы: 1
Наверх