엑셀

질문의 요지는 간단한데 처리하기가 상당히 난해한 질문이 올라왔습니다.

http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3675491

일단 특정 폴더에 같은 화일을 몰아넣고? 처리하는 방법을 생각해 보았습니다.
댓글에 있는 내용이지만 몇 개면 일일이 처리할 수 있겠지만(차라리 열어보고
수작업으로 비교해도 되겠지만요) 화일이 수십개면 그 내용까지 확인하면서
비교하기란 사실 불가능에 가깝다고 봐야겠지요.

댓글에서 힌트를 얻어 MD5 해시태그를 이용하는 방법이 제일 효율적이겠다
싶어서 구걸신에게서 태그 얻는 코드를 얻었습니다. 모르는 것이 없는 분이라…

이제 자동화 시킬 순서입니다. 우선 특정 폴더를 선택하여 전체 화일의 해시태그를
화일의 이름과 함께 수집합니다. 그 수집된 해시태그를 중복값 제거하고 한쪽으로
모읍니다. 물론 중복이 없으면 똑같은 수가 나열되겠지만 중복이 있으면 데이터의
행의 크기가 달라집니다.

중복된 값이 제거된 해시태그와 수집된 해시태그의 비교를 위해 이중 루프를 돌리면서
중복된 값이 있으면 그 태그 옆에 중복된 숫자를 표시하고 다시 중복된 숫자가 1보다
크게 나타나면 화일이 똑같은 것이 한개 이상 있다는 것이므로 랜덤한 수를 발생시켜
중복 화일에 동일한 컬러를 같이 보여줍니다.

이제 사용자의 편의를 위해 몇 가지 추가 기능을 넣습니다. 우선 화일이 오픈될 때
자동으로 버튼을 추가하고 그 버튼에 화일 비교 서브루틴을 연결시킵니다. 그리고
서브 루틴이 실행되고 나면 그 결과를 출력하고 위 상단에 2개 이상이 중복된 화일을
직접 제거할 수 있는 버튼과 서브 루틴을 추가하여 바로 제거할 수 있도록 하였습니다.

Option Explicit

Public xDirect$

Private Type MD5_CTX
i(1 To 2) As Long
buf(1 To 4) As Long
inp(1 To 64) As Byte
digest(1 To 16) As Byte
End Type

Private Declare Sub MD5Init Lib “cryptdll” (Context As MD5_CTX)
Private Declare Sub MD5Update Lib “cryptdll” (Context As MD5_CTX, ByVal strInput As String, ByVal lLen As Long)
Private Declare Sub MD5Final Lib “cryptdll” (Context As MD5_CTX)

Private Function CalcMD5(strFilename As String) As String
Dim strBuffer As String
Dim myContext As MD5_CTX
Dim result As String
Dim lp As Long
Dim MD5 As String
Dim MyPointer As Long
Dim MyFlag As Boolean

MyPointer = 65535
MyFlag = False

MD5Init myContext

If FileLen(strFilename) <= 65535 Then
strBuffer = Space(FileLen(strFilename))
Open strFilename For Binary Access Read As #1
Get #1, , strBuffer
MD5Update myContext, strBuffer, Len(strBuffer)
Close #1
Else
strBuffer = Space(65535)
MyPointer = 65535
Open strFilename For Binary Access Read As #1
Do Until MyFlag = True
Get #1, , strBuffer
MD5Update myContext, strBuffer, Len(strBuffer)
If FileLen(strFilename) – MyPointer < 65535 Then
strBuffer = Space(FileLen(strFilename) – MyPointer)
Get #1, , strBuffer
MD5Update myContext, strBuffer, Len(strBuffer)
MyFlag = True
Else
MyPointer = MyPointer + 65535
strBuffer = Space(65535)
End If
Loop
Close #1
End If

MD5Final myContext

result = StrConv(myContext.digest, vbUnicode)

For lp = 1 To Len(result)
CalcMD5 = CalcMD5 & Right(“00” & Hex(Asc(Mid(result, lp, 1))), 2)

Next

End Function

‘ 영역에서 중복 항목 제거해서 지정 위치에 세로로 출력
Sub UniqItemRng(SelRng As Range, TgtRng As Range)

Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection

Dim i As Integer, j As Integer, k As Integer
Dim Swap1, Swap2, item

Set AllCells = SelRng

On Error Resume Next

For Each Cell In AllCells

If Len(Cell.Value) > 0 Then ‘ 빈셀을 포함시키지 않음
‘ Add method의 2번째 인자는 문자열이어야만 함
NoDupes.Add Cell.Value, CStr(Cell.Value)

End If

Next Cell

On Error GoTo 0

For i = 1 To NoDupes.Count – 1

For j = i + 1 To NoDupes.Count

If NoDupes(i) > NoDupes(j) Then

Swap1 = NoDupes(i)
Swap2 = NoDupes(j)

NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1

End If

Next j

Next i

For Each item In NoDupes

TgtRng.Offset(k, 0).Value = item

k = k + 1

Next item

Set Cell = Nothing
Set AllCells = Nothing

End Sub

Sub Check_Uinq_Hash()

Dim i As Integer, cnt As Integer, rclr As Integer
Dim rngC As Range, rngMD5 As Range
Dim rngR As Range, rngRef As Range

cnt = 0

Set rngRef = Worksheets(“FList”).Range(“B:B”).SpecialCells(xlTextValues)
Set rngMD5 = Worksheets(“FList”).Range(“C:C”).SpecialCells(xlTextValues)

For Each rngC In rngMD5
For Each rngR In rngRef
If rngC = rngR Then
rngC.Offset(0, 1).Value = cnt + rngC.Offset(0, 1).Value

cnt = cnt + 1

End If
Next rngR

cnt = 0

Next rngC

For Each rngC In rngMD5
If rngC.Offset(0, 1).Value >= 1 Then

rclr = Int(Rnd() * 54) + 2

For Each rngR In rngRef
If rngR = rngC Then
rngC.Interior.ColorIndex = rclr
rngC.Offset(0, 1).Interior.ColorIndex = rclr

rngR.Offset(0, -1).Interior.ColorIndex = rclr
rngR.Interior.ColorIndex = rclr

End If

Next rngR
End If
Next rngC

End Sub

Sub Make_Button()

Dim rngBtn As Range

Rows(“1:2”).Insert Shift:=xlDown

Set rngBtn = [A1:D1]

With rngBtn
ActiveSheet.Buttons.Add(.Left, .Top, .Width, .Height * 2).Select

End With

With Selection
.Caption = “화일지우기”
.OnAction = “Delete_Dup_File”

End With

rngBtn.Select

End Sub

Sub Make_Start_Btn()

Dim rngBtn As Range

Dim tgt As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False

‘ 추출해서 붙여넣기할 데이터 시트가 기존에 있으면 삭제
For Each tgt In Worksheets
If tgt.Name = “Start” Then
tgt.Delete

End If
Next tgt

‘ 새 시트를 워크시트 제일 마지막에 FList라는 이름으로 추가
Set tgt = Worksheets.Add(after:=Worksheets(Worksheets.Count))
tgt.Name = “Start”

Sheets(“Start”).Activate

Set rngBtn = [C7:E7]

With rngBtn
ActiveSheet.Buttons.Add(.Left, .Top, .Width, .Height * 3).Select

End With

With Selection
.Caption = “화일 비교”
.OnAction = “Compare_Files”

End With

rngBtn.Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub Delete_Dup_File()

Dim FSO
Dim sFile As String
‘Set Object
Set FSO = CreateObject(“Scripting.FileSystemObject”)

sFile = ActiveCell.Value

‘Check File Exists or Not
If FSO.FileExists(sFile) Then
‘If file exists, It will delete the file from source location
FSO.DeleteFile sFile, True

MsgBox “삭제 완료”, vbInformation, “Done!”
Else
‘If file does not exists, It will display following message
MsgBox “화일이 존재하지 않습니다.”, vbInformation, “Not Found!”

End If

End Sub

Sub Compare_Files()

Dim xRow As Long
Dim xFname$, InitialFoldr$
Dim rngC As Range, rngRef As Range, rngMD5 As Range
Dim tgt As Worksheet

InitialFoldr$ = “C:\”

Application.DisplayAlerts = False
Application.ScreenUpdating = False

‘ 추출해서 붙여넣기할 데이터 시트가 기존에 있으면 삭제
For Each tgt In Worksheets
If tgt.Name = “FList” Then
tgt.Delete

End If
Next tgt

‘ 새 시트를 워크시트 제일 마지막에 FList라는 이름으로 추가
Set tgt = Worksheets.Add(after:=Worksheets(Worksheets.Count))
tgt.Name = “FList”

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & “\”
.Title = “Please select a folder to list Files from”
.InitialFileName = InitialFoldr$
.Show

If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & “\”
xFname$ = Dir(xDirect$, 7)

Do While xFname$ <> “”
Range(“A1”).Offset(xRow, 0) = xDirect$ & xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With

Set rngRef = tgt.Range(“A:A”).SpecialCells(xlTextValues)

For Each rngC In rngRef
rngC.Offset(0, 1).Value2 = CalcMD5(rngC.Value2)

Next rngC

Set rngMD5 = Worksheets(“FList”).Range(“B:B”).SpecialCells(xlTextValues)

Call UniqItemRng(rngMD5, Range(“C1”))

Call Check_Uinq_Hash

tgt.Columns.AutoFit

Call Make_Button

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

첨부 화일 : 20160311-파일 열지않고 같은 화일인지 비교, 삭제