[Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Excel Macro to Combine Duplicate Records

Posted on 2014-08-11
6
Medium Priority
?
227 Views
Last Modified: 2014-09-02
I have an MS Excel database that is populated with an import from MS Access.

I would like to embed a Macro into this Excel Spreadsheet that does the following functions:

1.      Automatically opens up any time it is updated (an import is received from Access)
2.      Has a Filter intact for each column when it opens
3.      Combines any duplicates:

Some records will have the exact same data except the 'AgentNo' column will be different.  I would like only one record that simply combines all the 'AgentNo's' into a single cell.
On stead of reading:

8/9/14      ABC International, Inc.         ABA12345      John Mistur      VP of Accounting
8/9/14      ABC International, Inc.         ABA54321      John Mistur      VP of Accounting

It should read:

8/9/14      ABC International, Inc.          ABA12345  ABA54321      John Mistur      VP of Accounting

4.      I would like this Macro Run, for this Spreadsheet, automatically every time it is open.

Can someone give me the Macro Code to do this?

Please see attached for the actual Spreadsheet.

Thank you.
excel-catch.xlsx
0
Comment
Question by:mdstalla
  • 3
  • 3
6 Comments
 
LVL 18

Accepted Solution

by:
krishnakrkc earned 2000 total points
ID: 40255103
Option Explicit

Sub kTest()
    
    Dim dic As Object, i As Long, aNo As Range, s As String
    Dim k, kk(), n As Long, aCol As Long, c As Long
    
    Const SheetName As String = "Table1 Query"      '<<<<<< adjust the sheet name
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    With ThisWorkbook.Worksheets(SheetName)
        Set aNo = Nothing
        Set aNo = .UsedRange.Find(what:="AgentNo", lookat:=xlWhole)
        If Not aNo Is Nothing Then
            aCol = aNo.Column
            k = .Range("a1").CurrentRegion.Value2
            ReDim kk(1 To UBound(k, 1), 1 To UBound(k, 2))
            For i = 2 To UBound(k, 1)
                s = vbNullString
                For c = 1 To UBound(k, 2)
                    If Not c = aCol Then s = s & "|" & k(i, c)
                Next
                If Len(s) Then
                    If Not dic.exists(s) Then
                        n = n + 1
                        For c = 1 To UBound(k, 2)
                            kk(n, c) = k(i, c)
                        Next
                        dic.Item(s) = n
                    Else
                        c = dic.Item(s)
                        kk(c, aCol) = kk(c, aCol) & ", " & k(i, aCol)
                    End If
                End If
            Next
            If n Then
                .Range("a1").CurrentRegion.Offset(1).ClearContents
                .Range("a2").Resize(n, UBound(kk, 2)).Value = kk
            End If
        End If
    End With
    
End Sub

Open in new window


Kris
0
 

Author Comment

by:mdstalla
ID: 40257619
Hi Kris—

I'm sorry, but I can't seem to make it work.  One challenge I'm having is that Excel is not letting me embed a Macro into the Spreadsheet.  I've tried changing it to a Macro-friendly spreadsheet but the code doesn’t seem to work.

I don't know if you can give advice on Access, but perhaps this process would work better on that platform.  
Let me give you a more detailed/clarified idea of what I'm trying to do:

Suppose I have an Access Database with a button ('Run Report'); and a Query (Table2 Query).
Upon clicking this button, I would like:

1.      The Database is saved; Table2 Query is exported to an Excel Spreadsheet (ExcelCatch1) and this Spreadsheet automatically opens.

2.      You will notice that it is possible for a single record to have multiple PassportNumbes.  On the spreadsheet, rather that displaying a record for each PassportNumber, I would like it to display a single record, with all of its PassportNumbers recorded in the same, single cell.

3.      In addition, I would like a filter placed at the top of each column.

4.      Each time this spreadsheet up updated through an import from Access, I would like it to replace the report that was already there (or update it with any new records).  I do not want it to create a new Sheet—all data should be presented on Sheet1.

Note:  I've attached a Sample Database, but unfortunately, I am unable to see any Access Databases that you send back to me (I'm having problems with this website).
Also, EcelCatch1 is located at:  C:\Users\Matt\Desktop\ExcelCatch1.xlsx

If you have a VBA Code that I could place into the 'Run Report' button that could do all of this, and could provide that code to me… it would be much appreciated.  If not, it would be extremely helpful if you could walk me though how to do this (where to put these codes).

Thank you so much!
Database39.accdb
0
 
LVL 18

Expert Comment

by:krishnakrkc
ID: 40257667
Add this code in the Access database (Goto Database Tools > Visual basic > Insert > Module )

and run kTest

Note: Please adjust the sheet name I mentioned in the code and the 'AgentNo' string I uded to find the column.

Option Compare Database
Option Explicit

Sub kTest()
    
    Dim dic As Object, i As Long, s As String
    Dim k, kk(), n As Long, aCol As Long, c As Long
    
    Dim xlApp   As Object
    Dim xlWbk   As Object
    Dim xlaNo   As Object
    
    Const xlFileName = "C:\Users\Matt\Desktop\ExcelCatch1.xlsx" '<<< change the file path and file name
    Const SheetName As String = "Table1 Query"      '<<<<<< adjust the sheet name
    
    
    Const xlWhole As Long = 1
    
    Set xlApp = CreateObject("Excel.Application")
        xlApp.UserControl = True
    Set xlWbk = xlApp.workbooks.Open(xlFileName)
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    With xlWbk.Worksheets(SheetName)
        Set xlaNo = Nothing
        Set xlaNo = .UsedRange.Find(what:="AgentNo", lookat:=xlWhole) '<< change the string
        If Not xlaNo Is Nothing Then
            aCol = xlaNo.Column
            k = .Range("a1").CurrentRegion.Value2
            ReDim kk(1 To UBound(k, 1), 1 To UBound(k, 2))
            For i = 2 To UBound(k, 1)
                s = vbNullString
                For c = 1 To UBound(k, 2)
                    If Not c = aCol Then s = s & "|" & k(i, c)
                Next
                If Len(s) Then
                    If Not dic.exists(s) Then
                        n = n + 1
                        For c = 1 To UBound(k, 2)
                            kk(n, c) = k(i, c)
                        Next
                        dic.Item(s) = n
                    Else
                        c = dic.Item(s)
                        kk(c, aCol) = kk(c, aCol) & ", " & k(i, aCol)
                    End If
                End If
            Next
            If n Then
                .Range("a1").CurrentRegion.Offset(1).ClearContents
                .Range("a2").Resize(n, UBound(kk, 2)).Value = kk
            End If
        End If
    End With
    
    Set xlaNo = Nothing
    xlWbk.Close 1
    Set xlWbk = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    
End Sub

Open in new window


Kris
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:mdstalla
ID: 40268202
Hi Kris:  

I was able to place your code into a module and run it-- and it performed the desired function... (Thank you for that) however, this requires me to manually export 'Table1 Query' to 'Excel Catch1;' run the module; and then manually open 'Excel Catch1.'

Would you happen to be able to expand on the code you gave me so that, upon the click of a button, Access automatically: 1. exports data from 'Table1 Query' to 'Excel Catch1;' 2. Runs the Module; 3. Opens 'Excel Catch1.'

Thanks again for your help.
0
 

Author Comment

by:mdstalla
ID: 40268203
Hi Kris:  

I was able to place your code into a module and run it-- and it performed the desired function... (Thank you for that) however, this requires me to manually export 'Table1 Query' to 'Excel Catch1;' run the module; and then manually open 'Excel Catch1.'

Would you happen to be able to expand on the code you gave me so that, upon the click of a button, Access automatically: 1. exports data from 'Table1 Query' to 'Excel Catch1;' 2. Runs the Module; 3. Opens 'Excel Catch1.'

Thanks again for your help.
0
 
LVL 18

Expert Comment

by:krishnakrkc
ID: 40269377
Hi

Try this one.

Option Compare Database
Option Explicit

Const xlFileName = "C:\Users\Matt\Desktop\ExcelCatch1.xlsx" '<<< change the file path and file name

Sub kTest()
    
    Dim dic As Object, i As Long, s As String
    Dim k, kk(), n As Long, aCol As Long, c As Long
    
    Dim xlApp   As Object
    Dim xlWbk   As Object
    Dim xlaNo   As Object
    
    Const SheetName As String = "Table1 Query"      '<<<<<< adjust the sheet name
    Const xlWhole As Long = 1
    
    CreateOutputFile
    
    Set xlApp = CreateObject("Excel.Application")
        xlApp.UserControl = True
    Set xlWbk = xlApp.workbooks.Open(xlFileName)
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    With xlWbk.Worksheets(SheetName)
        Set xlaNo = Nothing
        Set xlaNo = .UsedRange.Find(what:="AgentNo", lookat:=xlWhole) '<< change the string
        If Not xlaNo Is Nothing Then
            aCol = xlaNo.Column
            k = .Range("a1").CurrentRegion.Value2
            ReDim kk(1 To UBound(k, 1), 1 To UBound(k, 2))
            For i = 2 To UBound(k, 1)
                s = vbNullString
                For c = 1 To UBound(k, 2)
                    If Not c = aCol Then s = s & "|" & k(i, c)
                Next
                If Len(s) Then
                    If Not dic.exists(s) Then
                        n = n + 1
                        For c = 1 To UBound(k, 2)
                            kk(n, c) = k(i, c)
                        Next
                        dic.Item(s) = n
                    Else
                        c = dic.Item(s)
                        kk(c, aCol) = kk(c, aCol) & ", " & k(i, aCol)
                    End If
                End If
            Next
            If n Then
                .Range("a1").CurrentRegion.Offset(1).ClearContents
                .Range("a2").Resize(n, UBound(kk, 2)).Value = kk
            End If
        End If
    End With
    
    'if you don't want to close the workbook, comment the following lines
    Set xlaNo = Nothing
    xlWbk.Close 1
    Set xlWbk = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    
End Sub

Private Sub CreateOutputFile()
    
    On Error Resume Next
    Kill xlFileName
    On Error GoTo 0
    
    DoCmd.OutputTo acOutputQuery, "Table2 Query", "ExcelWorkbook(*.xlsx)", xlFileName, False
    
End Sub

Open in new window


Kris
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
Windows Explorer lets you open cabinet (cab) files like any other folder. In VBA you can easily handle normal files and folders, but opening and indeed creating cabinet files takes a lot more - and that's you'll find here.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

865 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question