Excel Macro многострочное условие поиска и вставка

Question

У меня есть колонка excelsheet «Диапазоны», в которой у меня есть многострочный текст в случайном порядке. Мне нужно найти конкретный префикс в многострочном тексте и вставить его в следующий столбец.

Цель состоит в том, чтобы найти префикс в порядке DS> FP> NP> HE и т. Д., Где, если префикс DS отсутствует, FP берется и так далее.

результат Образец листа выглядит следующим образом: -

Я следующий код до сих пор, пожалуйста, помогите мне решить эту задачу: -

Sub Rangess() 

    Dim colNum As Integer 
    colNum = ActiveSheet.rows(1).Find(What:="Range", LookAt:=xlWhole).Column 
    ActiveSheet.Columns(colNum + 1).Insert 
    ActiveSheet.Cells(1, colNum + 1).Value = "NEW" 

End Sub 

Answer 1

Вы можете использовать приведенный ниже код, который я тестировал на тест ca вы предоставили и его рабочий штраф.

Sub Test() 
    Dim colNum As Integer 
    colNum = ActiveSheet.Rows(1).Find(What:="Range", LookAt:=xlWhole).Column 
    ActiveSheet.Columns(colNum + 1).Insert 
    ActiveSheet.Cells(1, colNum + 1).Value = "NEW" 

    'counting no of rows 
    Dim No_Of_Rows As Long 
    No_Of_Rows = ActiveSheet.UsedRange.Rows.Count 

    Dim Range_col_val As Variant 
    Dim split_Range_col As Variant 
    Dim Range_splited_cell_val As Variant 
    Dim Prefix As Variant 
     Prefix = Array("DS", "FP", "NP", "HE") 
    Dim FLAG As Boolean 
    Dim j As Integer 



    'Looping for rows 

    For i = 2 To No_Of_Rows 

     'Extracting Data from col Range 

     Range_col_val = Cells(i, colNum).Value 
     split_Range_col = Split(Range_col_val, vbLf) 
     j = 0 
     ActiveSheet.Cells(i, colNum + 1).Value = split_Range_col(0) 
     FLAG = False 
     While FLAG = False And j < 5 
      'Looping for Each Line in Col Range 
      For k = LBound(split_Range_col) To UBound(split_Range_col) 
       Range_splited_cell_val = split_Range_col(k) 
       If (Range_splited_cell_val Like Prefix(j) & "*") Then 
        ActiveSheet.Cells(i, colNum + 1).Value = Range_splited_cell_val 
        FLAG = True 
       End If 
      Next k 
      j = j + 1 
     Wend 
    Next i 
End Sub 

Отредактировано код для создания 1-й строки, если ни один из вариантов не работает.

Answer 2

Try:

Sub test() 

Dim colNum As Long 
    colNum = ActiveSheet.Rows(1).Find(What:="Range", LookAt:=xlWhole).Column 
    ActiveSheet.Columns(colNum + 1).Insert 
    ActiveSheet.Cells(1, colNum + 1).Value = "NEW"   


Dim Arr As Variant 
Dim Lr As Long, R As Long 
Dim i As Long, n As Long 
Dim V As String, F As String 

Lr = Cells(Rows.Count, colNum).End(xlUp).Row  
Arr = Array("DS", "FP", "NP", "HE") 

For R = 2 To Lr 
    V = Cells(R, colNum).Value 
    For i = 0 To UBound(Arr) 
    n = InStr(V, Arr(i)) 
    If n <> 0 Then 
     F = Mid(V, n) 
     If InStr(F, vbLf) <> 0 Then F = Split(F, vbLf)(0) 
     Cells(R, colNum + 1).Value = F 
     Exit For 
    End If 
    Next 
Next 

End Sub