How do I handle duplicate data when I run this macro?

user_15568306 0
Viewed 48

I use this to create a list in Column B of my sheet. I would like to be able to change this to add the list starting at the bottom, so I can leave the existing data alone. This will create duplicates. I want the duplicates at the bottom removed leaving only NEW names.

I am a novice with VBA. I would appreciate some help.

Thanks!

Sub ListSubFolders()

'macro to pull folder names into the column

    Dim Cell        As Range
    Dim Folder      As Variant
    Dim SubFolders  As Variant
    Dim vArray      As Variant

        Set Cell = Range("B3")
        Folder = "R:\Bids\" & [C1]
                
        With CreateObject("Shell.Application")
            Set SubFolders = .Namespace(Folder).Items
                SubFolders.Filter 32, "*"
        End With
        
        If SubFolders.Count = 0 Then
            MsgBox "There are No Subfolders in this Directory."
            Exit Sub
        End If
        
        ReDim vArray(1 To SubFolders.Count, 1 To 1)
        
        For n = 0 To SubFolders.Count - 1
            vArray(n + 1, 1) = SubFolders.Item(n).Name
        Next n
        
        With Cell.Resize(n, 1)
            .NumberFormat = "@"
            .Value = vArray
        End With
        
 
    Range("B3").Select
    
    
End Sub
vba excel
1 Answers

List Subfolders: Update Existing List

Sub ListSubFolders()
    
    Const RootFolderName As String = "R:\Bids\"
    Const SubFolderNameAddress As String = "C1"
    Const sFirstCellAddress As String = "B3"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim FolderName As Variant
    FolderName = RootFolderName & ws.Range(SubFolderNameAddress)
            
    Dim SubFolders As Object: Set SubFolders _
        = CreateObject("Shell.Application").Namespace(FolderName).Items
    SubFolders.Filter 32, "*"
    If SubFolders.Count = 0 Then
        MsgBox "There are No Subfolders in this Directory."
        Exit Sub
    End If
    
    Dim srg As Range
    Dim dCell As Range
    Dim rCount As Long
    
    ' Write the existing folder names to a dictionary.
    
    With ws.Range(sFirstCellAddress)
        Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then
            Set dCell = .Cells
        Else
            rCount = lCell.Row - .Row + 1
            Set srg = .Resize(rCount)
            Set dCell = .Offset(rCount)
        End If
    End With
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Data As Variant
    Dim Key As Variant
    Dim r As Long
    
    If Not srg Is Nothing Then
        
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
        Else
            Data = srg.Value
        End If
        
        For r = 1 To rCount
            Key = Data(r, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    dict(Key) = Empty
                End If
            End If
        Next r
    
    End If
    
    ' Write the new folder names to a collection.
    
    Dim Coll As Collection: Set Coll = New Collection
    
    Dim Item As Variant
    
    For Each Item In SubFolders
        Key = Item.Name
        If Not dict.Exists(Key) Then
            dict(Key) = Empty
            Coll.Add Key
        End If
    Next Item
    
    ' Write the new folder names from the collection to an array.
    
    rCount = Coll.Count
    If rCount = 0 Then Exit Sub
        
    ReDim Data(1 To rCount, 1 To 1)
    r = 0
    
    For Each Key In Coll
        r = r + 1
        Data(r, 1) = Key
    Next Key
    
    ' Write the new folder names from the array to the range.
    
    With dCell.Resize(rCount)
        .NumberFormat = "@"
        .Value = Data
    End With
    
    MsgBox "Subfolder list updated.", vbInformation
    
End Sub
user_98140690
Related