VBA

Question

我正在尝试编写一个函数来获取列的名称 header 和我想从字符串中删除的值。该函数将从单元格中由“;”分隔的字符串中删除值并将字符串写回单元格。

例如，如果我用“B”调用函数：

（我从函数 getHeadersRange 得到的列名的范围，它工作正常）。

到目前为止我得到了：

Function ValueUpdateForMultipleValues(colName As String, ValueToDelete As String)

    Dim newItems As Variant
    Set Rng = getHeadersRange(colName)
    
    If Rng Is Nothing Then
        MsgBox (colName + " header was Not found")
    Else
    
        For Each cell In Rng
    
            items = Split(cell.Value, ";")
            maxValues = UBound(items)
            
            For i = 0 To maxValues
           
                If items(i) <> ValueToDelete Then
                    newItems = newItems & ";" & items(i)
                End If
                            
            Next i
            cell.Value = newItems
    
        Next cell
    
    End If

End Function

我没有收到任何错误，但字符串不是我需要的，而且有时第一个字符是“;”我不能拥有它。

谢谢！

Answer 1

您可以先检查您的字符串的第一个字符是否为 ;:

' Left function starts from the beginning of your string
' and returns the string up to the specified index
Left(valStr, 1) = ";"

如果是这样，您可以从字符串中删除第一个字符：

If Left(valStr, 1) = ";" Then

  ' Remove first character of string
  Right(valStr, Len(valStr)-1)

End If

要删除多余的字符，请查看此答案：

这里使用了以下函数：

Public Function SplitSemiColon(s As String) As String
    While Left(s, 1) = ";"
        s = Mid(s, 2)
    Wend

    While Right(s, 1) = ";"
        s = Left(s, Len(s) - 1)
    Wend

    SplitSemiColon = s
End Function

Answer 2

您可以根据需要探索 Regex 的使用，修改您的代码以更新您需要的列

Sub regex()

Dim regex As New RegExp
Dim stringPatter As String
Dim inputRange As Range

stringPatter = ";B"

With regex
    .Global = True
    .MultiLine = True
    .IgnoreCase = False
    .Pattern = stringPatter
End With

For Each inputRange In Sheet1.Range("A1:A5").Cells

    If regex.Test(inputRange.Value) Then
        inputRange.Value = regex.Replace(inputRange.Value, "")
    End If

Next

End Sub

前后对比

Answer 3

请使用您更新后的函数：

Function ValueUpdateForMultipleValues(colName As String, ValueToDelete As String)
    Dim items As Variant, rng As Range
    Set rng = getHeadersRange(colName)
    
    If rng Is Nothing Then
        MsgBox (colName & " header was Not found")
    Else
    
        For Each Cell In rng
            items = Split(Cell.value, ";")
            items = Filter(items, ValueToDelete, False)
            Cell.value = Join(items, ";")
        Next Cell
    End If
End Function
'I imagined a function able to return the range based on the column letter:
Function getHeadersRange(strCol As String) As Range
    Dim sh As Worksheet, lastR As Long
    Set sh = ActiveSheet
    lastR = sh.cells(sh.rows.count, strCol).End(xlUp).row
    Set getHeadersRange = sh.Range(sh.cells(1, strCol), sh.cells(lastR, strCol))
End Function

它将删除 ValueToDelete 及其“;”分隔器。您需要保留分隔符吗？

函数可以这样调用：

Sub testValueUpdateForMultipleValues()
  ValueUpdateForMultipleValues "F", "B"
End Sub

要处理“F:F”列中的范围，以消除“B”...

如果要处理的范围真的很大（超过一百万个单元格），可以调整函数，以便非常快，只在内存中工作。我的意思是，将范围放在数组中，处理数组并立即将其内容放回...

其实我也会post更新后的Function/Sub:

Function ValueUpdateForMultipleValuesArr(colName As String, ValueToDelete As String)
    Dim items As Variant, rng As Range, Cel As Range, i As Long, arr
    Set rng = getHeadersRange(colName)
    If rng Is Nothing Then
        MsgBox (colName & " header was Not found")
    Else
    arr = rng.Value2
        For i = 1 To UBound(arr)
            items = Split(arr(i, 1), ";")
            items = Filter(items, ValueToDelete, False)
            arr(i, 1) = Join(items, ";")
        Next i
    End If
    rng.Value2 = arr
    MsgBox "Ready..."
End Function

当然应该叫：

ValueUpdateForMultipleValuesArr "F", "B"

Answer 4

也可以使用替换来完成：

Function ValueUpdateForMultipleValues(colName As String, ValueToDelete As String)
    retval = " " & Replace(colName, UCase(ValueToDelete), "") & " "    'delete ValueToDelete and add spaces (see below)
    retval = Replace(retval, ";;", ";")             ' correct double ;
    retval = Replace(retval, " ;", "")              ' correct lead ;
    retval = Replace(retval, "; ", "")              ' correct final ;
    ValueUpdateForMultipleValues = Trim(retval)     ' delete extra spaces and return the value
End Function

Sub test()
    a = Array("A;B;C", "A;B;C", "A;B;C;D", "A;B")
    For Each s In a
        Debug.Print ValueUpdateForMultipleValues(CStr(s), "B")
    Next
End Sub

输出

A;C
A;C
A;C;D
A

VBA - 如何从以字符分隔的字符串中删除值

VBA - How to remove value from string delimited with character

arrays

string

delimiter