刪除重複項，而忽略字符串的開頭

Question

下面是我的代碼片段，它讀取一些單元格並將它們串在一起如何我想要的。我想忽略層數「COL1」

輸入重複的功能時，要刪除的重複可能是

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 

...並添加引用「Microsoft腳本運行」。