Question

下面是我的代码片段，它会读取一些单元格并将它们组合在一起。我希望在忽略图层编号＆＃39; col1＆＃39;

时删除重复项

输入重复功能可以

Layer  1:  25 xs  50 attaches at  6.98m and exhausts at  8.35m
Layer  2: 100 xs  75 attaches at  8.35m and exhausts at  13.5m
Layer  3:  44 xs 175 attaches at  13.5m and exhausts at 15.85m
Layer  4: 144 xs 175 attaches at  13.5m and exhausts at 21.43m
Layer  5: 148 xs 319 attaches at 21.43m and exhausts at 30.55m
Layer  6:  25 xs  50 attaches at  6.98m and exhausts at  8.35m
Layer  7: 100 xs  75 attaches at  8.35m and exhausts at  13.5m
Layer  8:  40 xs  35 attaches at  6.04m and exhausts at  8.35m
Layer  9:  65 xs  75 attaches at  8.35m and exhausts at 11.67m
Layer  9:  25 xs  50 attaches at  6.98m and exhausts at  8.35m
Layer 10: 100 xs 140 attaches at 11.67m and exhausts at   17.m
Layer 11: 148 xs 240 attaches at   17.m and exhausts at 25.51m
Layer 12: 162 xs 140 attaches at 11.67m and exhausts at 20.46m
Layer 13: 100 xs  35 attaches at  6.04m and exhausts at 11.41m
Layer 14:  65 xs  75 attaches at  8.35m and exhausts at 11.67m
Layer 14:  15 xs  35 attaches at  6.04m and exhausts at  6.98m
Layer 15:  25 xs  50 attaches at  6.98m and exhausts at  8.35m
Layer 16:  65 xs  75 attaches at  8.35m and exhausts at 11.67m

理想情况下返回

Layer  1:  25 xs  50 attaches at  6.98m and exhausts at  8.35m
Layer  2: 100 xs  75 attaches at  8.35m and exhausts at  13.5m
Layer  3:  44 xs 175 attaches at  13.5m and exhausts at 15.85m
Layer  4: 144 xs 175 attaches at  13.5m and exhausts at 21.43m
Layer  5: 148 xs 319 attaches at 21.43m and exhausts at 30.55m
Layer  8:  40 xs  35 attaches at  6.04m and exhausts at  8.35m
Layer  9:  65 xs  75 attaches at  8.35m and exhausts at 11.67m
Layer 10: 100 xs 140 attaches at 11.67m and exhausts at   17.m
Layer 11: 148 xs 240 attaches at   17.m and exhausts at 25.51m
Layer 12: 162 xs 140 attaches at 11.67m and exhausts at 20.46m
Layer 13: 100 xs  35 attaches at  6.04m and exhausts at 11.41m
Layer 14:  15 xs  35 attaches at  6.04m and exhausts at  6.98m

如果col1替换为数字并且列号相同，则代码仅执行此操作，因此在拆分均匀时生成字符串。

For Each cell In wb.Sheets("RP Analysis").Range("F5:F" & lastRow)

RSet col1 = WorksheetFunction.RoundDown(cell.Value, 2)
RSet col2 = WorksheetFunction.RoundDown(cell.Offset(0, 2).Value / 1000000, 2)
RSet col3 = WorksheetFunction.RoundDown(cell.Offset(0, 3).Value / 1000000, 2)
RSet col4 = Format$(WorksheetFunction.RoundDown(cell.Offset(0, 10).Value, 2), "#.##")
RSet col5 = Format$(WorksheetFunction.RoundDown(cell.Offset(0, 11).Value, 2), "#.##")
RSet col6 = Format$(WorksheetFunction.RoundDown(cell.Offset(0, 6).Value, 2), "#.##")
RSet col7 = Format$(WorksheetFunction.RoundDown(cell.Offset(0, 7).Value, 2), "#.##")



RMS = RMS & "Layer " & col1 & ":" & col2 & " xs " & col3 & " attaches at " & col4 & "m and exhausts at " & col5 & "m" & vbLf

AIR = AIR & "Layer " & col1 & ":" & col2 & " xs " & col3 & " attaches at " & col6 & "m and exhausts at " & col7 & "m" & vbLf

Next cell

For Each cell In wb.Sheets("RP Analysis").Range("A9:A" & 19)
    RSet col9 = Format$(WorksheetFunction.RoundDown(cell.Value, 2), "#####")
        gucurve = gucurve & col9 & ":-   " & Format(cell.Offset(0, 2).Value / cell.Offset(0, 1).Value, "Percent") & vbLf
Next cell

AIRmod = DeDupeString(AIR, vbLf)
RMSmod = DeDupeString(RMS, vbLf)

TextBox1.Value = "RP years  RMS/AIR difference" & vbLf & gucurve & vbLf & RMSmod & vbLf & AIRmod


End Function

下面是我删除重复项的功能，完美运行

Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String

Dim varSection As Variant
Dim sTemp As String

For Each varSection In Split(sInput, sDelimiter)
    If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
        sTemp = sTemp & sDelimiter & varSection
    End If
Next varSection

DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)

 End Function

Answer 1

一种简单的方法是使用Scripting.Dictionary。您可以使用该键将您关注的字符串部分存储为重复项，将原始值存储为项目。这样的事情应该有效：

Private Function DeDupSections(ByVal raw As String) As String
    Dim deduped As Object
    Set deduped = CreateObject("Scripting.Dictionary")

    Dim section As Variant
    Dim test As String
    For Each section In Split(raw, vbLf)
        If Len(section) > 9 Then
            test = Right$(section, Len(section) - 9)
            If Not deduped.Exists(test) Then
                deduped.Add test, section
            End If
        End If
    Next

    DeDupSections = Join(deduped.Items, vbLf) & vbLf
End Function

请注意，这是后期绑定。您可以通过将前两行更改为...来将其更改为早期界限。

Dim deduped As Scripting.Dictionary
Set deduped = New Scripting.Dictionary

...并添加对＆＃34; Microsoft Scripting Runtime＆＃34;。

的引用

删除重复项而忽略字符串的开头

1 个答案: