Results 1 to 3 of 3
  1. #1
    2 Star Lounger
    Join Date
    Mar 2007
    Location
    Wikltshire UK
    Posts
    152
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Delete Duplicate Entries in Excel (Access/Excel 2000)

    HI,

    We need to come up with a solution to a major problem were having with excel spreadsheets. I would like to create a Module in Access to do this as via a switchboard macro I can get the operator to just click a button to perform the task rather than having to import the Macro to the XL spreadsheet. I know the code below will give me access to the Spreadsheet but how to I create a Sub Routine which will eliminate all duplicate entries in Column "A", except if a column "P" is marked true??

    More Details available on request

    Dim xlApp As Object
    Dim xlWbk As Object
    Dim xlWsh As Object
    Dim blnStart As Boolean

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If xlApp Is Nothing Then
    Set xlApp = CreateObject("Excel.Application")
    If xlApp Is Nothing Then
    MsgBox "Cannot start Excel", vbExclamation
    Exit Function
    End If
    blnStart = True
    End If

    'On Error GoTo ErrHandler

    Set xlWbk = xlApp.Workbooks.Open("Cocuments and SettingsGraemeDesktopPay FilesMissing " & Left((MonDate1), 2) & " " & Mid(MonDate1, 4, 2) & ".xls")
    Set xlWsh = xlWbk.Worksheets("Pay_File")

    xlWsh.Columns.AutoFit
    xlWbk.Close SaveChanges:=True

    Yours in pre-emptive gratitude
    Graliv1

  2. #2
    Silver Lounger GARYPSWANSON's Avatar
    Join Date
    Aug 2001
    Location
    Frederick, Maryland, USA
    Posts
    1,788
    Thanks
    0
    Thanked 2 Times in 2 Posts

    Re: Delete Duplicate Entries in Excel (Access/Excel 2000)

    The excel automation to do what you want is possible, but it may be easier to point to the excel sheet as you did and transfer the data from the excel tab into access. You could then manipulate the data in access to get your results and then send the results back to the excel sheet.

    In access you could use a select distinct query to get all of the unique combinations. Then use another query to get the "p's". Use a union query to combine the data or write the data to a table and append the next query to it. Delete all of the data in the excel tab and then send it back to excel.

    In excel, you could start with the first cell and loop through the data looking for other matching values that do not have the P and then delete it and go on until all values have been checked. This is sort of a brute force method but should work.

    How many rows of data do you have?
    Regards,

    Gary
    (It's been a while!)

  3. #3
    Silver Lounger GARYPSWANSON's Avatar
    Join Date
    Aug 2001
    Location
    Frederick, Maryland, USA
    Posts
    1,788
    Thanks
    0
    Thanked 2 Times in 2 Posts

    Re: Delete Duplicate Entries in Excel (Access/Excel 2000)

    The following code should do what you want. Modify as necessary.

    <pre>'Set File Name
    strName = "C:TEST.xls"


    'Start Excel and Begin Processing
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlwbk = xlApp.Workbooks.Open(Filename:=strName)
    Set xlsht = xlwbk.Worksheets("SHEET1")

    xlApp.UserControl = True
    xlApp.Cursor = xlWait
    xlApp.StatusBar = "Processing"

    xlApp.Sheets("SHEET1").Select
    xlApp.ActiveWorkbook.Sheets("Sheet1").Activate

    With xlApp.ActiveSheet

    'Find the last row of data
    lngMaxR = xlsht.Cells(xlsht.Rows.Count, 1).End(xlUp).Row

    'Need two loops
    'x gets the first value
    'y searches the remainder of the list and starts after x

    For x = 1 To lngMaxR
    For y = x + 1 To lngMaxR

    'Get the value to be compared to and store as ValueInA
    'NextValue are the lower values used as a comparison

    ValueInA = xlsht.Cells(x, 1).Value
    NextValue = xlsht.Cells(y, 1).Value


    If ValueInA = NextValue Then 'Check to see if the values are equal
    If xlsht.Cells(y, 16) <> True Then 'Is Column P true?
    xlApp.Rows(y & ":" & y).Select 'If not true, delete the row and shift up
    xlApp.Selection.Delete Shift:=xlUp
    y = y - 1 'Need to decrease Y and LngMaxR as a row was deleted
    lngMaxR = lngMaxR - 1
    End If
    End If


    Next y
    Next x

    End With

    'Reset Excel Stuff

    xlApp.Cursor = Default
    xlApp.StatusBar = "Ready"

    xlwbk.Close savechanges:=True
    xlApp.Quit
    Set xlsht = Nothing
    Set xlwbk = Nothing
    Set xlApp = Nothing

    Exit Sub
    </pre>

    Regards,

    Gary
    (It's been a while!)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •