VBA кратчайший способ проверить ячейки, содержащие определенный текст

Question

У меня работает некоторый код VBA, но я хотел бы знать, есть ли более простой способ его кодирования. У меня есть список из 100 уникальных значений, и я хочу назначить категорию каждому из значений и написать название категории в другой ячейке

У меня есть оператор if-else, который проверяет каждое значение и выводит категорию.

Sub AssignCategory()
Dim rng As Range
Set rng = ActiveSheet.Range("A2:A100")
For Each cell In rng.Cells
    If InStr(1, cell, "Apple") Then
        cell.Offset(0, 2).Value = "Fruit"
    ElseIf InStr(1, cell, "Racoon") Then
        cell.Offset(0, 2).Value = "Animal"
    ElseIf InStr(1, cell, "Lion") Then
        cell.Offset(0, 2).Value = "Animal"
    ElseIf InStr(1, cell, "Quartz") Then
        cell.Offset(0, 2).Value = "Mineral"
    ElseIf InStr(1, cell, "Watermelon") Then
        cell.Offset(0, 2).Value = "Fruit"
    End If
Next
End Sub

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

Answer 1

Оператор Select Case позволит вам объединить несколько параметров в один результат.

Sub AssignCategory()

    Dim rng As Range
    Set rng = ActiveSheet.Range("A2:A100")
    For Each cell In rng.Cells

        Select Case lcase(cell.value2)
          case "apple", "orange", "pear", "watermelon"
            cell.Offset(0, 2).Value = "Fruit"
          case "lion", "raccoon"
            cell.Offset(0, 2).Value = "Animal"
          case "quartz"
            cell.Offset(0, 2).Value = "Mineral"
          case else  'no match to anything above
            cell.Offset(0, 2).Value = "no category"
        end select

    Next cell

End Sub

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

Answer 2

Вы можете попробовать Select ... case Microsoft

Answer 3

вы можете использовать что-то подобное для проверки содержания определенного текста в ячейке. Если у вас есть список дел, его будет легче поддерживать:

Sub AssignCategory()
    Dim rng As Range
    Dim cell As Range, key
    Set rng = ActiveSheet.[A2:A100]
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")

    dic.Add "*apple*", "Fruit"
    dic.Add "*watermelon*", "Fruit"
    dic.Add "*racoon*", "Animal"
    dic.Add "*lion*", "Animal"
    dic.Add "*quartz*", "Mineral"

    For Each cell In rng.Cells
        For Each key In dic
            If LCase(cell) Like key Then
                cell.Offset(, 2).Value = dic(key)
                Exit For
            End If
        Next
    Next
End Sub

Если вам нужно проверить этоячейка соответствует определенному тексту, затем используйте select ... case:

Sub AssignCategory2()
    Dim rng As Range
    Dim cell As Range
    Set rng = ActiveSheet.[A2:A100]

    For Each cell In rng.Cells
        Select Case LCase(cell)
            Case "apple", "watermelon": cell.Offset(, 2).Value = "Fruit"
            Case "racoon", "lion": cell.Offset(, 2).Value = "Animal"
            Case "quartz": cell.Offset(, 2).Value = "Mineral"
        End Select
    Next
End Sub

Answer 4

для меня вы можете создать 1 лист Excel, который будет вашим датированным, а затем вы можете создать функцию для чтения листа Excel и работать как sql.

см. Пример ниже. убедитесь, что вы добавили библиотеку объектов данных Microsoft ActiveX

Function getStringValue() As String

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset


strFile = Workbooks(1).FullName

strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"


Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")


cn.Open strCon

''modify this sql statement as per your requirement

strSQL = "SELECT * FROM [Sheet1$A1:E346] where ID =1" ''Range

rs.Open strSQL, cn

getValue = rs.GetString

End Function