ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Range.Find problem (https://www.excelbanter.com/excel-programming/447655-range-find-problem.html)

tris55
Range.Find problem
 
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 list of file names into a column, and then applies some logic to each value in that range to populate another column.

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

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

The range it is checking is populated by a large formula, I'm not sure 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 alternative method of checking the range for a duplicate value I would be happy to use that.

Thank you for your time,

Tristan

Ben McClave
Range.Find problem
 
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. I have 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 is that 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 If
Quote:
Originally Posted by tris55 (Post 1607441)
I am still having issues with this problem, if there is an alternative method of checking the range for a duplicate value I would be happy to use that.

Thank you for your time,

Tristan


All times are GMT +1. The time now is 03:57 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com