Announcement

Collapse
No announcement yet.

Remove Duplicates & Create Word Documents For Each Group

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Remove Duplicates & Create Word Documents For Each Group



    Hi,

    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.

    Thanks
    Attached Files

  • #2


    Re: Remove Duplicates & Create Word Documents For Each Group

    Hi,

    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.InsertParagraphAfter
    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)
    wordDoc.Content.InsertParagraphAfter
    End If
    End If
    Next
    dic.removeall
    Next
    Flg = False
    i = i + k
    End If
    Next
    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
    Else
    .Item(a(i, 1)) = .Item(a(i, 1)) + 1
    End If
    End If
    Next
    TBs = .keys
    TBCOUNTs = .items
    End With
    End Sub
    Kris

    ExcelFox

    Comment

    Working...
    X