[RESOLVED] Creating unique list and writing to files

Hello there!

I'm the definition of a newbie so please be a bit paitent. :)

I have an Excel sheet with quite much information (about 13000 rows).
The interesting columns are A, D and E containing the following information:
- Column A contains a long list of names, all unique.
- Column D contains "group names".
- Column E contains Owners of the groups.
(Look at it as product names, product groups and responible persons for the groups.)
Row 1 contains the text "Names", "Group Names" and "Owners", the actual data starts at row 2.

What I want to do is:
1. Create a new sheet named "Owners" containing a list of all the group names and all owners associated with the groups.
2. Create a bunch of files named after the group names and the extention ".ext" e.g. <group1.ext>. containing the first row [Names] and then the all the names (one on each row) for that group listed below.

Example: ( [] = Cell)
[Names][ ][ ][Group Names][Owners]
[tcce1][ ][ ][group1 ][peter;john;sarah;]
[tcce2][ ][ ][group1 ][peter;john;liza;]
[rc_f ][ ][ ][group2 ][kent;sarah;]
This would result in a list on the Owners sheet looking like this:

[Group Name][Owners]
[group1 ][peter;john;sarah;liza]
[group2 ][kent;sarah;]

The file "group1.ext" (ordinary text file) should contain exactly the following:
[Names]
tcce1
tcce2

I'm using a form with two buttons to execute the 2 different Subs. I've managed to create a sheet named Owners and to create a list. The list is incorrect in some way though.

VB Code:

Private Sub CmdButGenExtFiles_Click()
 
End Sub
 
Private Sub CmdButGenOwnList_Click()
 
    Dim rListPaste As Range
    Dim ws As Worksheet
    
    For Each ws In Worksheets               'Check for Sheet with name "Owners"
        If ws.name = "Owners" Then
            MsgBox "There is a sheet with the name Owners already.", vbInformation
            Exit Sub
        End If
    Next
    
    Sheets.Add After:=Sheets(Sheets.Count)  'Add new sheet
    ActiveSheet.name = "Owners"             'Name it "Owners"
    Range("A1").Select                          'Select cell A1
    ActiveCell.FormulaR1C1 = "Group name:"    'and write Group name in it
    Range("B1").Select                          'Select cell B1
    ActiveCell.FormulaR1C1 = "Owners:"          'and write Owners in it
 
    Rows("1:1").Select                      'Select top Row and change font properties
    With Selection.Font
        .name = "Arial"
        .Size = 14
        .Bold = True
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ColorIndex = xlAutomatic
    End With
    
    Columns("B:B").ColumnWidth = 25         'Change Column widths
    Columns("A:A").ColumnWidth = 25
 
    On Error Resume Next
    Worksheets("Owners").Activate           'Activate sheet "Owners"
    Set rListPaste = Range("A2")            'rListPaste = A2 at sheet Owners
    
    Worksheets("Data").Activate             'Select the Data sheet and paste the unique list
    
    Range("D2", Range("D2").End(xlDown)).AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=Worksheets("Owners").Range("A2"), Unique:=True
 
End Sub

I guess this is a quite massive problem to bring up in a forum, but all tips, ideas and help are greatly appreciated.

Best regards.

VB Code:

Private Sub CmdButGenExtFiles_Click()
Open "Group1.ext" For Output As 1
Print #1, "Names"
For i = 2 To Sheet1.UsedRange.Rows.Count
    If Sheet1.Cells(i, 4) = "group1" Then Print #1, Sheet1.Cells(i, 1)
    
Next
Close 1
End Sub

should write your text file

i don't think you can do what you are trying to do with filters as you want to get part of cells value (each owner), then add to list of owners for each group

i would change the code from and including on error resume next

VB Code:

' don't use    On Error Resume Next
    Worksheets("Owners").Activate           'Activate sheet "Owners"
' not used    Set rListPaste = Range("A2")            'rListPaste = A2 at sheet Owners
    
    Worksheets("Data").Activate             'Select the Data sheet and paste the unique list
    
    Range("D2", Range("D2").End(xlDown)).AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=Worksheets("Owners").Range("A2"), Unique:=True
 
 
    
    
    
    With Worksheets("data")
        For i = 2 To .UsedRange.Rows.Count
            olistarr = split(.Cells(i, 5), ";")
                For o = 2 To Worksheets("Owners").UsedRange.Rows.Count
                    If Worksheets("Owners").Cells(o, 1) = .Cells(i, 4) Then
                        owns = Worksheets("Owners").Cells(o, 2)
                        For j = 0 To UBound(olistarr)
                            If InStr(1, owns, olistarr(j)) = 0 Then owns = owns & ";" & olistarr(j)
                            
                        Next j
                        Worksheets("Owners").Cells(o, 2) = owns
                        Exit For
                    End If
                Next o
        Next i
    End With

this code is not tested as i only have office 97 here and split don't work (VBA5)

pete

i have tested it now, seems that the unique key does not stop duplicate records, my answer would be to write code to do the same job (i know progamming better than excel functions), similar to the code for the second part, which seems to work ok

pete

Thanks!
:thumb:
This solved the problem. I had to do some work to get everything to work exactly as I wanted but your help was without doubt a great contribution to solve the problem (and helping me getting a grip of the syntax)!

What would the world look like without For, If and While? :D

Best regards