Range.Find problem

[tris55]

Hello everyone,

First time poster here, looking for some help with the following code:


Code
-------------------

Set dupRange = Range("B5:B33000")
dupSearch = Cells(r, 2)

Set dup = dupRange.Find(dupSearch)
If dup Is Nothing Then
Resume Next
End If

-------------------


This is part of some more code that I am writing which reads in a lis
of file names into a column, and then applies some logic to each valu
in that range to populate another column.

The next part of the code then renames the files with the new colum
values. The above code is called when the program tries to rename a fil
to a name that already exists. I then want to identify the other valu
(filename) and rename them both. However, the above code does not wor
correctly, i.e. it does not return "dup" when there is a matching valu
in the range.

I cannot understand why this problem occurs, I've read around a lot o
the forums and google, but cannot find anything that helps. I am sure i
is me doing something silly.

The range it is checking is populated by a large formula, I'm not sur
if this could cause the problem.

Sorry if I am not explaining clearly, I'm pretty new to this.

For reference the entire code is below, I apologise for the messiness
it could probably be done much better.


Code
-------------------
Sub List_Files()
Dim MyFolder As String
Dim MyFile As String
Dim a As Integer

'Date Created Object
Dim oFS As Object

MyFolder = (Cells(2, 2).Value2 & "\")
MyFile = Dir(MyFolder & "*.*")
a = 4

Do While MyFile <> ""
a = a + 1
Cells(a, 1).Value = MyFile

'Date Modified code:
Set oFS = CreateObject("Scripting.FileSystemObject")

Cells(a, 3).Value = oFS.GetFile(MyFolder & MyFile).DateLastModified

Set oFS = Nothing

'End of Date Modified code

MyFile = Dir
Cells(3, 5).Value = a - 4
Loop
MsgBox "Success. Files imported: " & (a - 4)

End Sub

Sub ReName_Files()
On Error GoTo ErrHandler:
Dim MyFolder As String
Dim MyFile As String
Dim r As Integer
Dim e As Integer
Dim we As Integer
Dim d As Integer
Dim dupSearch As String
Dim dup As Range
Dim dupRange As Range

'Definition of counters
d = 0
e = 0
we = 0
'Folder locations
MyFolder = (Cells(2, 2).Value2 & "\")
MyFile = Dir(MyFolder & "*.*")
'Counter variable
r = 5

'Loop Through until cells are empty
Do Until IsEmpty(Cells(r, 1)) Or IsEmpty(Cells(r, 2))

' Short name (usually excluding number) catch
If Len(Cells(r, 1)) < 14 Then
e = e + 1
Cells(12, 5).Value = e
Cells(e + we + d + 2, 6).Value = Cells(r, 1) & " (Name is too short)"
Cells(r, 4).Value = Cells(r, 4).Value & "Short Name "
End If

' Catch for non pdf files
If UCase(Cells(r, 12).Value) <> "PDF" Then
we = we + 1
Cells(9, 5).Value = we
Cells(e + we + d + 2, 6).Value = Cells(r, 1) & " (Not a PDF)"
Cells(r, 4).Value = Cells(r, 4).Value & "Non PDF "
Cells(r, 2).Value = Cells(r, 1).Value
End If

' No underscore before last 9 digits in name
If Cells(r, 14).Value <> "_" Then
e = e + 1
Cells(12, 5).Value = e
Cells(e + we + d + 2, 6).Value = Cells(r, 1) & " (Check name)"
Cells(r, 4).Value = Cells(r, 4).Value & "Incorrect Format "
Cells(r, 2).Value = Cells(r, 1).Value
r = r + 1
Else
' Renaming Code *IMPORTANT*
Name MyFolder & Cells(r, 1).Value As MyFolder & Cells(r, 2).Value
r = r + 1
Cells(6, 5).Value = r - 5
End If

Loop
MsgBox "All old file names in Column 'A' have now been renamed" & vbCr & _
"to the adjacent new name in column 'B'." & vbCr & "Files renamed: " & (r - 5)

ErrHandler:
If Err.Number = 58 Then

'.Find solution
d = d + 1
Set dupRange = Range("B5:B33000")
dupSearch = Cells(r, 2) '.Value
MsgBox ("Duplicate Search is: " & dupSearch & " when r is: " & r & "The previous Cell is " & Cells(r - 1, 2))

Set dup = dupRange.Find(dupSearch)
If dup Is Nothing Then
MsgBox ("Dup didn't find anything when r is: " & r)
Resume Next
Else
MsgBox ("dup found: " & dup & " when r is: " & r)
End If

If Cells(r, 3).Value < dup.Offset(1, 0) Then
Name MyFolder & Cells(r, 1).Value As MyFolder & "OLD" & d & "_" & Cells(r, 2).Value
Name MyFolder & dup.Offset(0, -1) As MyFolder & "NEW" & d & "_" & dup
Cells(15, 5).Value = d
Cells(e + we + d + 2, 6).Value = "OLD" & d & "_" & Cells(r, 2) & " (Old Duplicate)"
Cells(r, 4).Value = Cells(r, 4).Value & "Old Duplicate "
Cells(r, 2).Value = "OLD" & d & "_" & Cells(r, 2).Value
dup = "NEW" & d & "_" & dup
Else
Name MyFolder & Cells(r, 1).Value As MyFolder & "NEW" & d & "_" & Cells(r, 2).Value
Name MyFolder & dup.Offset(0, -1) As MyFolder & "OLD" & d & "_" & dup
Cells(15, 5).Value = d
Cells(e + we + d + 2, 6).Value = "NEW" & d & "_" & Cells(r, 2) & " (New Duplicate)"
Cells(r, 4).Value = Cells(r, 4).Value & "New Duplicate "
Cells(r, 2).Value = "NEW" & d & "_" & Cells(r, 2).Value
dup = "OLD" & d & "_" & dup
End If

Set dup = Nothing

Resume Next
End If

MsgBox Err.Description

End Sub
--------------------

 

[tris55]

I am still having issues with this problem, if there is an alternativ
method of checking the range for a duplicate value I would be happy t
use that.

Thank you for your time,

Trista

 

[Ben McClave]

Hello,

Ozgrid.com has a great find function (http://www.ozgrid.com/forum/showthread.php?t=27240) to return a range of cells using the Find function. You could also adapt that function to instead return a boolean if you only care about whether a duplicate exists (and don't care where the duplicate resides on the sheet). Take a look at the thread above for the Range version. Ihave adapted the function to return a boolean below. For example, entering:

Find_Dup(Cells(r, 2), Range("B5:B33000"))

would return TRUE if a duplicate value exists and FALSE otherwise. Here isthat code:

Function Find_Dup(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Boolean

'Adapted from:
'http://www.ozgrid.com/forum/showthread.php?t=27240

Find_Dup = False

Dim c As Range
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
If IsMissing(MatchCase) Then MatchCase = False

With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Find_Dup = True
End If
End With

End Function

 

[tris55]

I have now solved the issue.

For those interested the new code was:


Code
-------------------
Dim dup As Object
Set dupRange = Range("B5:B" & r - 1)
dupSearch = Cells(r, 2)

dupRange.Select

Set dup = Selection.Find(What:=dupSearch, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If dup Is Nothing Then
Resume Next
End I