Question

我正在尝试让我的宏打开一个新工作簿并粘贴所有具有重复值的行。我希望它为每组重复值创建一个新的工作簿。

更具体地说，我的代码假设选择基于datediff值为2的单元格，将具有相同唯一标识符的所有单元格组合在一起，然后将其复制并粘贴到新工作簿中。

例如，如果单元格值是，

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

宏将复制A1的整行，然后将其粘贴到新工作簿中，然后复制A4和A5的整行，并将其粘贴到另一个新工作簿中，因为这些是列B = 2的单元格。会这样做，直到列中没有任何值。

我的代码存在的问题是，它打开了10多个不同的新工作簿，其中一些没有值。前几个做了我想要的但最后几个是空白的。

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

任何帮助都会令人惊叹并真正受到赞赏。

Answer 1

整个子包裹在for循环中

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

您的工作表创建在此循环中，因此对于每个值，将运行整组代码。我没有看过这一切，但你可以先添加一个if语句来跳过某些不会产生输出的值。

!! VBA代码：选择重复项并复制唯一值

1 个答案: