Help with VBA code (finding duplicates and creating unique values)

[Sw4mq]

Hello,

I receive daily spreadsheets that contain both a column displaying latitudes and a column displaying the corresponding longitudes. However, due to the precision of the GPS instruments, there are often duplicate values, see below.

ID	Latitude	Longitude
1	41.01289749	-92.48545074
2	41.01290894	-92.48544312
3	41.01290894	-92.48544312
4	41.01291656	-92.48544312

I'm looking to create a VBA script that searches the latitude and longitude column for duplicates, then adds or subtracts a number to the end from said duplicate in order to create a unique value. They are always 8 decimals.

These values are consecutive so the trend line is always going to move in the same direction. In the case of the Latitudes in the example above, the column 3 latitude would be decreased by .00000001 in order to create a unique value as that's the way the trend is going.

If anyone could help me out with this they would be a life saver and save me so much time.

Thanks!

 

[Sw4mq]

Edit:

I have the following code that sorts through the above data and removes duplicates:

Sub lime()
   Application.ScreenUpdating = False
   Dim a, lastrow As Long, checkCol As Range, targetWorksheet As Worksheet
   lastrow = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
   lastcol = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
   Set targetWorksheet = Worksheets("Sheet1")
   With targetWorksheet
      For k = 1 To lastcol
         For I = 1 To lastrow
            Set checkCol = .Range(.Cells(1, k), .Cells(lastrow, k))
            If WorksheetFunction.CountIf(checkCol, Cells(I, k)) > 1 Then
               If Cells(I, k) <> "" Then
                  checkCol.Replace what:=Cells(I, k).Value, Replacement:="", _
                  LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                  SearchFormat:=False, ReplaceFormat:=False
               End If
            End If
         Next I
      Next k
   End With
   Application.ScreenUpdating = True
End Sub

Is there a way to fill the blanks now with linear values? I know there is a fill command but I am unsure how to add it into this VBA script.

​

 

[Sw4mq]

Edit 2:

I created a vba code that sort of works. How can I tie these together into one script and have the linear extrapolation & assignment apply to more than one column? In the code below it's applied to column B only. How do I apply it to both B & C? Also, it also won't populate the first cells if they are blank since it has nothing above those blank cells to extrapolate from. Any ideas?

Sub lime()
   Application.ScreenUpdating = False
   Dim a, lastRow As Long, checkCol As Range, targetWorksheet As Worksheet
   lastRow = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
   lastcol = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
   Set targetWorksheet = Worksheets("Sheet1")
   With targetWorksheet
      For k = 1 To lastcol
         For i = 1 To lastRow
            Set checkCol = .Range(.Cells(1, k), .Cells(lastRow, k))
            If WorksheetFunction.CountIf(checkCol, Cells(i, k)) > 1 Then
               If Cells(i, k) <> "" Then
                  checkCol.Replace what:=Cells(i, k).Value, Replacement:="", _
                  LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                  SearchFormat:=False, ReplaceFormat:=False
               End If
            End If
         Next i
      Next k
   End With
   Application.ScreenUpdating = True
End Sub

Sub interpolate()
  On Error Resume Next
For Each cell In Range("B1:B25")
    If cell.Value = "" Then
        y2 = cell.End(xlDown).Value
        x2 = cell.End(xlDown).Offset(0, -1).Value
        y1 = cell.End(xlUp).Value
        x1 = cell.End(xlUp).Offset(0, -1).Value
        x = cell.Offset(0, -1).Value
        y = (y1) + (x - x1) * (y2 - y1) / (x2 - x1)
        cell.Value = y
    End If
Next
End Sub