질문의 요지는 간단한데 처리하기가 상당히 난해한 질문이 올라왔습니다.
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-파일 열지않고 같은 화일인지 비교, 삭제
3월 11 2016
엑셀(EXCEL) – 파일 열지않고 같은 화일인지 비교 후 중복 화일 삭제
질문의 요지는 간단한데 처리하기가 상당히 난해한 질문이 올라왔습니다.
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-파일 열지않고 같은 화일인지 비교, 삭제
By vinipapa • 무른모 • 0 • Tags: 비교, 삭제, 엑셀, 자동 버튼 추가0, 중복화일