CODEWITHSUNDEEP
vbaexcel
s.patter
s.patter

Reputation: 5

!!VBA CODE: Selecting Duplicates and Copying Unique Values

I am trying to make my macro open a new workbook and paste all the rows that have duplicate values. I want it to create a new workbook for each set of duplicate values.

More specifically, My code is suppose to select cells based on a datediff value of 2, group all the cells with the same unique Identifier together, then copy and paste it into a new workbook.

For instance if the cell values were,

A1= 1234  B1= 2 
A2= 1234  B2= 5 
A3= 321   B3= 7 
A4= 234   B4= 2
A5= 234   B5= 2

The macro would copy the entire row for A1 then paste it into a new workbook and then copy the entire row of A4 and A5 and paste it into another new workbook, because those are the cells that have column B= 2. It would do this until no values are left in the columns.

The problem with my code, is that it opens 10+ Different new workbooks, some with values some without. The first few does what I wanted but the last few are blank. 

Sub test()
Dim wbNew As Workbook
lr = Range("A" & Rows.Count).End(xlUp).Row
myarr = uniqueValues(Range("A1:A" & lr))
For i = LBound(myarr) To UBound(myarr)

 With Sheet1
        .AutoFilterMode = False
        .Range("A1").AutoFilter Field:=1, Criteria1:=myarr(i)
        .AutoFilter.Range.EntireRow.Copy
 Set wbNew = Workbooks.Add()
 wbNew.Worksheets(1).Paste

    Workbooks("Workbook2.xlsm").Sheets("Invoice Template (2)").Copy Before:=wbNew.Sheets(1)
    ActiveSheet.Name = "Current Invoice"

    Dim s As Integer
    s = 2

    Dim t As Integer
    t = 21

    wbNew.Worksheets(2).Activate

    Do Until IsEmpty(Cells(s, 3))
    mini = Cells(s, 21).Value
    If mini = "2" Then

    Dim wsInvoice As Worksheet
    Set wsInvoice = wbNew.Sheets("Current Invoice")

        wsInvoice.Cells(t, 2).Value = Cells(s, 10).Value    'Volumes'
        wsInvoice.Cells(t, 3).Value = Cells(s, 8).Value     'Benefits'
        wsInvoice.Cells(t, 7).Value = Cells(s, 11).Value    'Rates'
        wsInvoice.Cells(8, 2).Value = Cells(s, 14).Value    'Insurer Name'
        wsInvoice.Cells(9, 2).Value = Cells(s, 16).Value    'Insurer Address'
        wsInvoice.Cells(13, 2).Value = Cells(s, 3).Value    'Client Name'
        wsInvoice.Cells(14, 2).Value = Cells(s, 4).Value    'Client Address'
        wsInvoice.Cells(10, 9).Value = Cells(s, 1).Value    'Policy Number'
        wsInvoice.Cells(11, 9).Value = Cells(s, 22).Value   'Renewal Date'
        wsInvoice.Cells(12, 9).Value = Cells(s, 20).Value   'Anniversary Date'

    With wsInvoice
    Select Case Cells(s, 9)
        Case 1001  'Formula for Life, AD & D, ASI, CI'
            Prem = (.Cells(t, 2) * .Cells(t, 7)) / 1000
        Case 1103  'Formula for LTD'
            Prem = (.Cells(t, 2) * .Cells(t, 7)) / 100
        Case 1104  'Formula for STD'
            Prem = (.Cells(t, 2) * .Cells(t, 7)) / 10
        Case 2112  'General Formula'
            Prem = (.Cells(t, 2) * .Cells(t, 7))
    End Select

    .Cells(t, 9).Value = Prem
    End With

    With wsInvoice
    Select Case Cells(s, 15)
        Case 5501 'Commission schedule AIG'

        Case 5502 'Commission schedule ACE INA'

        Case 5503 'Commission schedule BBD'
            FrontL = 1
            HBack = 0
        Case 5504 'Commission schedule CBA'

        Case 5505 'Commission schedule ENCON'

        Case 5506 'Commission schedule Fenchurch'
            FrontL = 1
            HBack = 0
        Case 5507 'Commission schedule Great West Life'
            FrontL = 1
            HBack = 0
        Case 5508 'Commission schedule Great West Life SelectPac'
            FrontL = 1
            HBack = 0
        Case 5509 'Commission schedule Greenshield Canada'

        Case 5510 'Commission schedule GHG'

        Case 5511 'Commsion Schedule Industrial Alliance'
            FrontL = 0.9
            HBack = 0.1
        Case 5512 'Commission schedule Manulife'
            FrontL = 0.9
            HBack = 0.1
        Case 5513 'Commission schedule RBC'
            FrontL = 0.8
            HBack = 0.2
        Case 5514 'Commission schedule SunAdvantage'
            FrontL = 0.9
            HBack = 0.1
            Comm = 0.06
        Case 5515 'Commission schedule Sun Life Financial'
            FrontL = 0.9
            HBack = 0.1
            Comm = 0.1
    End Select

    .Cells(38, 8).Value = FrontL
    .Cells(39, 8).Value = HBack
    .Cells(18, 4).Value = Comm
    End With

        t = t + 1

    End If


    s = s + 1

    Loop

End With


Next i
End Sub


Dim cell As Range
Dim tempList As Variant: tempList = ""
For Each cell In InputRange
    If cell.Value <> "" Then
        If InStr(1, tempList, cell.Value) = 0 Then
            If tempList = "" Then tempList = Trim(CStr(cell.Value)) Else tempList = tempList & "|" & Trim(CStr(cell.Value))
        End If
    End If
Next cell
uniqueValues = Split(tempList, "|")
End Function

Any Help would be amazing and truly appreciated.

Upvotes: 0

Views: 1578

Answers (1)

sten
sten

Reputation: 380

The entire sub is wrapped in a for loop

For i = LBound(myarr) To UBound(myarr)

Your sheet creations are inside this loop so for each value the entire set of code will run. I haven't looked at it all but you could start by adding an if statement to skip certain values that will produce no output.

Upvotes: 1

Related Questions