Generate GUID, Find Duplicates, Replace, Rescan

  • Follow


I am trying to find a way to generate GUIDs, which I've found, but I
need to ensure they are truly unique. Here is the script that
generates the GUIDs

Sub GenerateGUID()

    Dim c As Long, r As Range
    c = 1
    Set r = Range("a2")

    Do Until r.Cells(c, 1) = ""

    Dim strGUID As String
    Set TypeLib = CreateObject("Scriptlet.TypeLib")
    strGUID = Left(TypeLib.GUID, 38)



    r.Cells(c, 16).Value = strGUID
    c = c + 1



    Set TypeLib = Nothing

    Loop
End Sub


Here is the script that scans for duplicates. I need a couple changes,
but I don't know how to do them. First, I need it to generate the
GUIDs with the above script. I'm guessing that can be a separate
process. Second, I need it to scan the list (column) it just made. If
it finds a duplicate, I need it to replace the entry with another
GUID, not delete it. Once it regenerates, I need it to rescan the list
from the beginning, finishing out with truly, verified, unique IDs.


Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through.
iListCount = Sheets("Sheet1").Range("A1:A100").Rows.Count
Sheets("Sheet1").Range("A1").Select
' Loop until end of records.
Do Until ActiveCell = ""
   ' Loop through records.
   For iCtr = 1 To iListCount
      ' Don't compare against yourself.
      ' To specify a different column, change 1 to the column number.
      If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then
         ' Do comparison of next record.
         If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value
Then
            ' If match is true then delete row.
            Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp
               ' Increment counter to account for deleted row.
               iCtr = iCtr + 1
         End If
      End If
   Next iCtr
   ' Go to next record.
   ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Thanks for the help.
0
Reply christopher 6/1/2010 4:34:16 AM


0 Replies
1104 Views

(page loaded in 0.024 seconds)

Similiar Articles:
















7/18/2012 5:58:49 PM


Reply: