如何消除一个“文件目录”行的小时参数

例如，我在excel中有一个文件结构的行。

Row 1 c:\User\Folder100\13-25\File100.log Row 2 c:\User\Folder200\11-16\File200.log Row 3 c:\User\Folder300\21-20\File300.log Row 4 c:\User\Folder400\13-25\File400.log Row 5 c:\User\Folder400\9-10\File400.log Row 6 c:\User\Folder500\8-16\File500.log Row 7 c:\User\Folder600\8-16\File600.log Row 8 c:\User\Folder700\11-16\File700.log Row 9 c:\User\Folder700\9-40\File700.log 

第一行没有任何问题，因为文件日志不同，但是行（4和5）a在两个不同的文件夹“c：\ User \ Folder400 \ 13-25 \”和c ：\ User \ Folder400 \ 9-10 \我想只保留13-25（排除第5行），因为有更近的时间。

另外，第8和第9行我只想保留第8行（11-16）

 Row 1 c:\User\Folder100\13-25\File100.log Row 2 c:\User\Folder200\11-16\File200.log Row 3 c:\User\Folder300\21-20\File300.log Row 4 c:\User\Folder400\13-25\File400.log Row 6 c:\User\Folder500\8-16\File500.log Row 7 c:\User\Folder600\8-16\File600.log Row 8 c:\User\Folder700\11-16\File700.log 

（排除第5和第9行）

你知道任何想法如何使它在VBA？

Answer 1

这并不是完全达到目的，而是用来说明你可以如何去解决这样的问题。

它只考虑文件名和它之前的时间string。 该文件夹可以根据需要添加。

主要模块：

 Option Explicit Private dict As dictionary 'Prints the rows you need (time criterion applied) Private Sub FindDuplicates() Dim lastRow As Long, row As Long Dim x As Variant, v As Variant Dim fileName As String, timeString As String Set dict = CreateObject("Scripting.Dictionary") 'Determine last row lastRow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row 'Iterate and store in dictionary For row = 1 To lastRow x = Split(Cells(row, 1), Application.PathSeparator) fileName = x(UBound(x)) timeString = x(UBound(x) - 1) AddDictEntry fileName, row, timeString Next row 'Print results For Each v In dict.Keys Debug.Print "FileName: " & v & ", Recent Version: " & dict.Item(v) Next End Sub 

添加/删除字典条目：

 Private Sub AddDictEntry(fileName As String, rowNo As Long, timeString As String) Dim timeParts As Variant, timeLong As Long 'converts time string to long, for comparison timeParts = Split(timeString, "-") timeLong = CInt(timeParts(0)) * 100 + CInt(timeParts(1)) 'Adds entry to dictionary if time is more recent If (dict.Exists(fileName)) Then If CInt(dict.Item(fileName)) < timeLong Then dict(fileName) = timeLong End If Else dict.Add fileName, timeLong End If End Sub 

---

input：

 c:\User\Folder100\13-25\File100.log c:\User\Folder200\11-16\File200.log c:\User\Folder300\21-20\File300.log c:\User\Folder400\13-25\File400.log c:\User\Folder400\9-10\File400.log c:\User\Folder300\22-20\File300.log 

输出：

 FileName: File100.log, Recent Version: 1325 FileName: File200.log, Recent Version: 1116 FileName: File300.log, Recent Version: 2220 FileName: File400.log, Recent Version: 1325 

Answer 2

下面的代码

1. 使用RegEx将文件夹名称和文件编号提取到两个新列（请参阅下图）
2. 按列B对列进行sorting，然后按列C对列进行sorting
3. 使用Excels Remove DuplicatesfunctionRemove Duplicates列B中存在重复项的整个行（最新的时间在列CV中首先保留）
4. 删除两个工作列

更新：下面的代码假设“用户”后面的第一个文件夹和文件名很匹配，它是重复的 – 最初的指导方针仍然是模糊的。 此代码确实解决了问题中显示的示例

 Sub Sliced() Dim lngRow As Long Dim lngCalc As Long Dim objReg As Object Dim objDic As Object Dim rng1 As Range Dim X() Dim Y() Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp)) 'See Patrick Matthews excellent article on using Regular Expressions with VBA Set objReg = CreateObject("vbscript.regexp") objReg.Pattern = "(.+\\){2}(.+\\)(\d+)\-\d+\\(.+)" 'Speed up the code by turning off screenupdating and setting calculation to manual 'Disable any code events that may occur when writing to cells With Application lngCalc = .Calculation .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With 'Test each area in the user selected range X = rng1.Value2 Y = X For lngRow = 1 To UBound(X) 'replace the leading zeroes X(lngRow, 1) = objReg.Replace(X(lngRow, 1), "$2$4") Y(lngRow, 1) = objReg.Replace(Y(lngRow, 1), "$3") Next Columns("B:C").Insert rng1.Offset(0, 1) = X rng1.Offset(0, 2) = Y With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=rng1.Offset(0, 1), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=rng1.Offset(0, 2), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal .SetRange rng1.Cells(1).Offset(0, 1).Resize(rng1.Rows.Count, 2) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveSheet.UsedRange.RemoveDuplicates Columns:=2, Header:=xlNo Columns("B:C").Delete 'cleanup the Application settings With Application .ScreenUpdating = True .Calculation = lngCalc .EnableEvents = True End With Set objReg = Nothing End Sub