2

たとえば、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 2 つの異なるフォルダー "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で作成する方法を知っていますか?

4

2 に答える 2

3

以下のコード

  1. a を使用しRegExて、フォルダー名とファイル番号を 2 つの新しい列に抽出します (下の図を参照)。
  2. 列を列 B で並べ替え、次に列 C で降順で並べ替えます
  3. Excels機能を使用して、列Bに重複が存在する行全体を削除しRemove Duplicatesます（最新の時刻が列CVの最初になるため、保持されます）
  4. 2 つの作業列を削除します

更新: 以下のコードは、"User" の後の最初のフォルダーとファイル名の両方が重複していることを前提としています。最初のガイドラインはまだあいまいです。このコードは、質問に示されている例を解決します

ここに画像の説明を入力

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
于 2012-11-19T11:26:04.250 に答える
2

これは目的を正確に果たすものではありませんが、このような問題に対処する方法を説明するのに役立ちます.

ファイル名とその前の時間文字列のみが考慮されます。フォルダは必要に応じて追加できます。

メインモジュール:

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

入力：

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
于 2012-11-19T11:10:01.837 に答える