0

Excel シートのセットがあり、それぞれ次のように設定されています。

ID | imageName
--------------
1    abc.jpg
2    def.bmp
3    abc.jpg
4    xyz123.jpg

このシートは、次のような内容のフォルダーに対応しています。

abc.pdf
ghijkl.pdf
def.pdf
def.xls
x-abc.pdf

imageNameそれぞれのインスタンスとそれに一致する最も低いPDF を一致させるレポートを生成しようとしています。また、シート内の一致しないものとフォルダー内の一致しない PDF をID識別します。imageName「x-」接頭辞が付いたファイル名は、接頭辞がないファイル名と同等であるため、このデータ セットのレポートは次のようになります。

ID  imageName   filename
-----------------------
1   abc.jpg     abc.pdf
1   abc.jpg     x-abc.pdf
2   def.bmp     def.pdf
4   xyz123.jpg 
                ghijkl.pdf

私の現在の解決策は次のとおりです。

'sheetObj is the imageName set, folderName is the path to the file folder
sub makeReport(sheetObj as worksheet,folderName as string)

dim fso as new FileSystemObject
dim imageDict as Dictionary
dim fileArray as variant
dim ctr as long


'initializes fileArray for storing filename/imageName pairs
redim fileArray(1,0) 

'returns a Dictionary where key is imageName and value is lowest ID for that imageName
set imageDict=lowestDict(sheetObj)

'checks all files in folder and populates fileArray with their imageName matches
for each file in fso.getfolder(folderName).files
 fileFound=false
 'gets extension and checks if it's ".pdf"
 if isPDF(file.name) then 
  for each key in imageDict.keys
   'checks to see if base names are equal, accounting for "x-" prefix
   if equalNames(file.name,key) then 
    'adds a record to fileArray mapping filename to imageName
    addToFileArray fileArray,file.path,key  
    fileFound=true
   end if
  next
  'checks to see if filename did not match any dictionary entries
  if fileFound=false then 
   addToFileArray fileArray,file.path,""
  end if
 end if
next

'outputs report of imageDict entries and their matches (if any)
for each key in imageDict.keys
 fileFound=false
 'checks for all fileArray matches to this imageName
 for ctr=0 to ubound(fileArray,2)
  if fileArray(0,ctr)=key then
   fileFound=true
   'writes the data for this match to the worksheet
   outputToExcel sheetObj,key,imageDict(key),fileArray(0,ctr)
  end if
 next
 'checks to see if no fileArray match was found
 if fileFound=false then
  outputToExcel sheetObj,key,imageDict(key),""
 end if
next

'outputs unmatched fileArray entries
for ctr=0 to ubound(fileArray,2)
  if fileArray(1,ctr)="" then
   outputToExcel sheetObj,"","",fileArray(0,ctr)
  end if
next

このプログラムはレポートを正常に出力しますが、非常に遅いです。For ループがネストされているため、imageNameエントリとファイルの数が増えると、それらを処理する時間が指数関数的に増加します。

これらのセットで一致を確認するより良い方法はありますか? ディクショナリにすると高速になる可能性がありますfileArrayが、ディクショナリに重複キーを含めることはできず、ファイル名が複数の imageName に一致する可能性があるため、このデータ構造にはフィールドに重複するエントリが必要です。

4

3 に答える 3

0

回答ありがとうございます。

でファイル名の配列を作成folderNameし、WinAPIFindFirstFileとFindNextFile関数を使用してフォルダーを通過することでこれを解決しました。これは、ネットワークを介しているため、返されたコレクションを反復処理するのfso.getfolder(foldername).filesが遅すぎるためです。

次に、ファイル名配列からファイル名/ベース名辞書を作成しました。

key         | value
-----------------------
abc.pdf     | abc
x-lmnop.pdf | lmnop
x-abc.pdf   | abc

fileConcatこの辞書から、次のように、重複したベース名からキーを連結する逆辞書を作成しました。

key         | value
-----------------------
abc         | abc.pdf,x-abc.pdf
lmnop       | lmnop.pdf

imageDict次に、各キーのベース名を のキーに一致fileConcatさせ、次によって生成された連結値の配列を反復処理することができました。

split(fileConcat(key))

はキーkeyのベース名です。imageDict

@chrisneilsen がコメントしたように、ネストされた For ループを削除すると、成長率が に低下しO(ImageNames)+O(Files)、関数は満足のいく速度で実行されるようになりました。

于 2012-07-19T16:53:18.207 に答える
0

これにより、最初のものがすぐに見つかるはずです。最後の if ステートメントの内部では、好きなことを行うことができます。ネストされたforループよりも高速なADOレコードセットを使用します

Sub match()
Dim sheetName As String: sheetName = "Sheet1"
Dim rst As New ADODB.Recordset
Dim cnx As New ADODB.Connection
Dim cmd As New ADODB.Command

    'setup the connection
    '[HDR=Yes] means the Field names are in the first row
    With cnx
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source='" & ThisWorkbook.FullName & "'; " & "Extended Properties='Excel 8.0;HDR=Yes;IMEX=1'"
        .Open
    End With

    'setup the command
    Set cmd.ActiveConnection = cnx
    cmd.CommandType = adCmdText
    cmd.CommandText = "SELECT * FROM [" & sheetName & "$]"
    rst.CursorLocation = adUseClient
    rst.CursorType = adOpenDynamic
    rst.LockType = adLockOptimistic

    'open the connection
    rst.Open cmd

    Dim fso As FileSystemObject: Set fso = New FileSystemObject
    Dim filesInFolder As files, f As File
    Set filesInFolder = fso.GetFolder("C:\Users\Bradley\Downloads").files

    For Each f In filesInFolder
        rst.MoveFirst
        rst.Find "imageName = '" & f.Name & "'", , adSearchForward
        If Not rst.EOF Then
            Debug.Print rst("imagename") & "::" & rst("ID") '<-- Do what you need to do here
        End If
    Next f

End Sub

参考：この投稿を参考にしました

于 2012-07-18T23:28:13.593 に答える
0

別の方法。

Sub Sample()
    Dim ws As Worksheet, wstemp As Worksheet
    Dim FileAr() As String
    Dim n As Long, wsLRow As Long

    Set ws = Sheets("Sheet1") '<~~ Which has imageNames   
    wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

    n = 0

    strFile = Dir("C:\Temp\*.*")

    Do While strFile <> ""
        n = n + 1
        ReDim Preserve FileAr(n)

        If Mid(strFile, Len(strFile) - 3, 1) = "." Then
            FileAr(n) = Mid(strFile, 1, Len(strFile) - 4)
        ElseIf Mid(strFile, Len(strFile) - 4, 1) = "." Then
            FileAr(n) = Mid(strFile, 1, Len(strFile) - 5)
        Else
            FileAr(n) = strFile
        End If

        strFile = Dir
    Loop

    Set wstemp = Worksheets.Add
    wstemp.Range("A1").Resize(UBound(FileAr) + 1, 1).Value = Application.Transpose(FileAr)

    ws.Range("B1:B" & wsLRow).Formula = "=IF(ISERROR(VLOOKUP(A1," & wstemp.Name & _
                                        "!A:A,1,0)),"""",VLOOKUP(A1," & wstemp.Name & "!A:A,1,0))"

    ws.Range("B1:B" & wsLRow).Value = ws.Range("B1:B" & wsLRow).Value

    Application.DisplayAlerts = False
    wstemp.Delete
    Application.DisplayAlerts = True
End Sub
于 2012-07-18T23:43:01.603 に答える