Ozgrid Excel Help & Best Practices Forums

Excel Training / Excel Dashboards Reports

Results 1 to 2 of 2

Thread: Remove Duplicates & Create Word Documents For Each Group

  1. #1
    Join Date
    20th December 2008

    Remove Duplicates & Create Word Documents For Each Group


    Attached is a spreadsheet with raw data. The columns contain the units of a textbook, and the rows contain educational state standards that correspond with those units. I need to create a Word document for IL and GA, converting the rows of data into a listing of standards for each unit. I also need to remove all duplicates.

    For this I need a macro written. If necessary, please include a brief description of your process in your return email or in an attached document.

    The completed Word document for NJ is included as an example. I am willing to pay $10 for this task.

    Attached Files. REMINDER! OzGrid accepts no responsibility for ANY adverse effects as a result from downloading attached files. ALWAYS run an up-to-date virus scan and disable macros.

  2. #2
    Join Date
    18th November 2004
    God's Own Country

    Re: Remove Duplicates & Create Word Documents For Each Group


    Public TBs      As Variant 
    Public TBCOUNTs As Variant 
    Sub GenerateDocs() 
         ' add a reference to the Word-library
         ' go to tools > reference > check Microsoft Word X.0 Object Library. where X is the version #
        Dim a, i As Long, MyTBs, ws As Worksheet, j As Long 
        Dim x, c As Long, k As Long, Flg As Boolean 
        Dim dic As Object 
        Dim wordApp As Word.Application 
        Dim wordDoc As Word.Document 
        Set ws = ActiveSheet 
        Set wordApp = CreateObject("Word.Application") 
        wordApp.Visible = True 
        Set wordDoc = wordApp.Documents.Add 
        Set dic = CreateObject("scripting.dictionary") 
        dic.comparemode = vbTextCompare 
        a = ws.UsedRange 
        MyTBs = Array("IL", "GA") 'add your preferences here
        TBCOUNT ws.Range("a3", ws.Range("a" & Rows.Count).End(xlUp)).Value 
        Redim w(1 To Rows.Count, 1 To 1) 
        For i = 3 To UBound(a, 1) 
            x = Application.Match(a(i, 1), MyTBs, 0) 
            If Not IsError(x) Then Flg = True 
            If Flg Then 
                With Application 
                    k = .Index(TBCOUNTs, .Match(a(i, 1), TBs, 0)) 
                End With 
                For c = 2 To UBound(a, 2) 
                    wordDoc.Content.InsertAfter a(2, c) 
                    For j = i To k + i - 1 
                        If Not IsEmpty(a(j, c)) Then 
                            If Not dic.Exists(a(j, c)) Then 
                                wordDoc.Content.InsertAfter a(j, c) 
                            End If 
                        End If 
                Flg = False 
                i = i + k 
            End If 
    End Sub 
    Private Sub TBCOUNT(a) 
        Dim i As Long 
        With CreateObject("scripting.dictionary") 
            .comparemode = vbTextCompare 
            For i = 1 To UBound(a, 1) 
                If Not IsEmpty(a(i, 1)) Then 
                    If Not .Exists(a(i, 1)) Then 
                        .Add a(i, 1), 1 
                        .Item(a(i, 1)) = .Item(a(i, 1)) + 1 
                    End If 
                End If 
            TBs = .keys 
            TBCOUNTs = .items 
        End With 
    End Sub 

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Possible Answers

  1. Replies: 1
    Last Post: August 18th, 2003, 05:16


Posting Permissions

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