独特的魔法

Question

我对JS和Python有一定的经验，但是在我的VBA历程中还是相对较新的。到目前为止，我已经写了一些成功的脚本，但是确实为此感到挣扎。

这是我的问题的简化示例：

我需要它，以便我的每个工作表都具有C列的唯一值。但是，我不想删除其他内容，我想保留它们，将它们复制/粘贴到新的工作表中，然后希望能够再次在该工作表中运行宏，直到我有很多工作表，每个工作表在C列中只有唯一的值。

所以：

Sheet 1

+-----------+------------------------+---------+
| Name (A)  |         Email  (B)     |Animal(C)|
+-----------+------------------------+---------+
| Lauretta  | Lauretta@barnyard.com  | Pig     |
| Kanisha   | Kanisha@barnyard.com   | Pig     |
| Katelynn  | Katelynn@barnyard.com  | Pig     |
| Irwin     | Irwin@barnyard.com     | Cat     |
| Renea     | Renea@barnyard.com     | Cat     |
| Antonette | Antonette@barnyard.com | Cat     |
| Leigh     | Leigh@barnyard.com     | Donkey  |
| Eloy      | Eloy@barnyard.com      | Horse   |
| Jamika    | Jamika@barnyard.com    | Horse   |
| Kristian  | Kristian@barnyard.com  | Horse   |
| Elaina    | Elaina@barnyard.com    | Spider  |
| Catherina | Catherina@barnyard.com | Spider  |
| Ellamae   | Ellamae@barnyard.com   | Spider  |
+-----------+------------------------+---------+

看起来像这样：

Sheet 1

+-----------+------------------------+---------+
| Name (A)  |         Email  (B)     |Animal(C)|
+-----------+------------------------+---------+
| Lauretta  | Lauretta@barnyard.com  | Pig     |
| Irwin     | Irwin@barnyard.com     | Cat     |
| Leigh     | Leigh@barnyard.com     | Donkey  |
| Eloy      | Eloy@barnyard.com      | Horse   |
| Elaina    | Elaina@barnyard.com    | Spider  |
+-----------+------------------------+---------+

Sheet 2

+-----------+------------------------+---------+
| Name (A)  |         Email  (B)     |Animal(C)|
+-----------+------------------------+---------+
| Kanisha   | Kanisha@barnyard.com   | Pig     |
| Katelynn  | Katelynn@barnyard.com  | Pig     |
| Renea     | Renea@barnyard.com     | Cat     |
| Antonette | Antonette@barnyard.com | Cat     |
| Jamika    | Jamika@barnyard.com    | Horse   |
| Kristian  | Kristian@barnyard.com  | Horse   |
| Catherina | Catherina@barnyard.com | Spider  |
| Ellamae   | Ellamae@barnyard.com   | Spider  |
+-----------+------------------------+---------+

这时我希望可以在Sheet 2上运行相同的宏，从而生成：

Sheet 2

+-----------+------------------------+---------+
| Name (A)  |         Email  (B)     |Animal(C)|
+-----------+------------------------+---------+
| Kanisha   | Kanisha@barnyard.com   | Pig     |
| Renea     | Renea@barnyard.com     | Cat     |
| Jamika    | Jamika@barnyard.com    | Horse   |
| Catherina | Catherina@barnyard.com | Spider  |
+-----------+------------------------+---------+

Sheet 3

+-----------+------------------------+---------+
| Name (A)  |         Email  (B)     |Animal(C)|
+-----------+------------------------+---------+
| Katelynn  | Katelynn@barnyard.com  | Pig     |
| Antonette | Antonette@barnyard.com | Cat     |
| Kristian  | Kristian@barnyard.com  | Horse   |
| Ellamae   | Ellamae@barnyard.com   | Spider  |
+-----------+------------------------+---------+

希望这是有道理的。为了节省空间，我将花一些时间从下面收集我从各个地方收获的一些嵌合憎恶品，这些东西不起作用:(我确实一直在尝试！

任何帮助都将不胜感激！：）

Answer 1

嵌合憎恶（不要问宏名称哈哈 facepalm ：

Option Explicit
Sub pinky()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet

Set sh = Sheets("Sheet1")`
lw = Range("A" & Rows.Count).End(xlUp).Row`

For i = 1 To lw 'Find duplicates from the list.
       If Application.CountIf(Range("C" & i & ":C" & lw), Range("C" & i).Text) > 1 Then
       Range("C2", Range("C65536").End(xlUp)).EntireRow.Copy
       sh.Range(Worksheets(2)).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Selection.AutoFilter

           ' Range("C" & i).Value = 1
        End If
    Next i    

End Sub

另一个：

Sub bowie()
    Dim xRgS As Range
    Dim xRgD As Range
    Dim i As Long, J As Long
    On Error Resume Next
    Set xRgS = Range("C:C")
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Worksheets(2)
    If xRgD Is Nothing Then Exit Sub
    xRows = xRgS.Rows.Count
    J = 0
    For i = xRows To 1 Step -1
        If Application.WorksheetFunction.CountIf(xRgS, xRgS(i)) > 1 Then
            xRgS(i).EntireRow.Copy xRgD.Offset(J, 0)
            xRgS(i).EntireRow.Delete
            J = J + 1
        End If
    Next
End Sub

另一个：

Sub bowietwo()
'Updateby Extendoffice
    Dim xRgS As Range
    Dim xRgD As Range
    Dim i As Long, J As Long
    On Error Resume Next
    Set xRgS = Application.InputBox("Please select the column:", "Hi! John says:", Selection.Address, , , , , 8)
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("Please select a desitination cell:", "Hi! John says:", , , , , , 8)
    If xRgD Is Nothing Then Exit Sub
    xRows = xRgS.Rows.Count
    J = 0
    For i = xRows To 1 Step -1
        If Application.WorksheetFunction.CountIf(xRgS, xRgS(i)) > 1 Then
            xRgS(i).EntireRow.Copy xRgD.Offset(J, 0)
            xRgS(i).EntireRow.Delete
            J = J + 1
        End If
    Next
End Sub

此^^排序有效，但立即崩溃，我的动物列表数以万计

Option Explicit
Sub Brian()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet

Set sh = Sheets("Dup")
lw = Range("A" & Rows.Count).End(xlUp).Row

    For i = 1 To lw 'Find duplicates from the list.
       If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) > 1 Then
            Range("B" & i).Value = 1
        End If
    Next i

    Range("A1:B10000").AutoFilter , Field:=2, Criteria1:=1
    Range("C2", Range("C65536").End(xlUp)).EntireRow.Copy
    sh.Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Selection.AutoFilter
End Sub

因此，事实证明，小指，鲍伊，bowietwo和brian没有用。我知道必须是一种简单，优雅的方法。

Answer 2

独特的魔法

Workbook Download（Dropbox）

代码

Sub UniqueMagic()

    Const cFR As Long = 1             ' Header Row Number
    Const cFC As Variant = "A"        ' First Column Letter/Number
    Const cColU As Variant = "C"      ' Unique Column Letter/Number
    Const cSheet As String = "Sheet"  ' Worksheet Pattern

    Dim ws As Worksheet   ' Source (Unique) Worksheet
    Dim wsK As Worksheet  ' Keep Worksheet
    Dim rng As Range      ' LucH - Last Used Cell (Range) in Header Row
                          ' LucU - Last Used Cell (Range) in Unique Column
    Dim dict As Object    ' Dictionary
    Dim key As Variant    ' Dictionary Key (For Each Control Variable)
    Dim vntS As Variant   ' Source Array
    Dim vntR As Variant   ' Row Array
    Dim vntU As Variant   ' Unique Array
    Dim vntK As Variant   ' Keep Array
    Dim NorS As Long      ' Source Number of Rows
    Dim NorU As Long      ' Unique Number of Rows
    Dim NorK As Long      ' Keep Number of Rows
    Dim Noc As Long       ' Number of Columns
    Dim FC As Long        ' First Column Number
    Dim ColU As Long      ' Source Array Unique Column Number
    Dim i As Long         ' Source/Keep Array Row Counter
    Dim j As Long         ' Column Counter
    Dim k As Long         ' Row/Unique Array Row Counter
    Dim strSh As String   ' Keep Worksheet Name Concatenator

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    ' Handle unexpected error.
    On Error GoTo ErrorHandler

    ' Task: Write values from Source Worksheet (ws) to Source Array (vntS).

    ' Create a reference to Source Worksheet.
    Set ws = ThisWorkbook.ActiveSheet
    ' In Source Worksheet
    With ws
        ' Calculate and create a reference to LucH.
        Set rng = .Columns(cColU).Find("*", , xlFormulas, , , xlPrevious)
        ' Write row number of LucH to Number of Rows.
        NorS = rng.Row - cFR + 1
        ' Calculate and create a reference to LucU.
        Set rng = .Rows(cFR).Find("*", , xlFormulas, , , xlPrevious)
        ' Calculate First Column Number.
        FC = .Columns(cFC).Column
        ' Write row number of LucU to Number of Columns.
        Noc = rng.Column - FC + 1
        ' Calculate Source Array Unique Column Number.
        ColU = .Columns(cColU).Column - FC + 1
        ' Calculate Source Range.
        ' Copy Source Range to Source Array.
        vntS = .Cells(cFR, cFC).Resize(NorS, Noc)
    End With

    ' Task: Write Source Array row numbers (i) for first found ('unique')
    '       values to Dictionary (dict) and row numbers (i) for again found
    '       values to Row Array (vntR).

    ' Resize 1D 1-based Row Array to Source Number of Rows.
    ReDim vntR(1 To NorS)
    ' Create a reference to Dictionary.
    Set dict = CreateObject("Scripting.Dictionary")
    ' Loop through Rows of Source Array (first row are headers).
    For i = 2 To NorS
        ' Check if current value in Source Array does not exists in Dictionary.
        If Not dict.Exists(vntS(i, ColU)) Then ' Does NOT exist in Dictionary.
            ' Add current value in Source Array to Key and current Source
            ' Row Number in Source Array to Value of Dictionary.
            dict.Add vntS(i, ColU), i
          Else ' Does EXIST in Dictionary.
            ' Count number of elements in Row Array.
            k = k + 1
            ' Write current Source Row Number to current row in Row Array.
            vntR(k) = i
        End If
    Next

    ' Task: Write from Source Array (vntS) to Keep Array (vntK).

    ' Check if any 'non-unique' values have been found.
    If k = 0 Then GoTo UniqueMessage ' Inform user.
    ' Resize Row Array to current row count of Row Array (k) i.e.
    ' remove empty values.
    ReDim Preserve vntR(1 To k)
    ' Write size (rows) of Row Array to Keep Number of Rows.
    NorK = k + 1 ' + 1 for Headers
    ' Resize Keep Array to Keep Number of Rows and Number of Columns.
    ReDim vntK(1 To NorK, 1 To Noc)
    ' Write Headers from Source Array to Keep Array.
    For j = 1 To Noc
        vntK(1, j) = vntS(1, j)
    Next
    ' Write Body Keep Values from Source array to Keep Array.
    For i = 2 To NorK
        For j = 1 To Noc
            vntK(i, j) = vntS(vntR(i - 1), j)
        Next
    Next
    Erase vntR ' No longer needed. Data is in Keep Array.

    ' Task: Copy Keep Array (vntK) to Keep Range (rng) in newly created
    '       Keep Worksheet(wsK).

    ' Write Source Worksheet Name to Keep Worksheet Name Concatenator.
    strSh = ws.Name
    ' Apply numbering to Worksheet Name Concatenator.
    strSh = cSheet & CStr(Right(strSh, Len(strSh) - Len(cSheet)) + 1)
    ' Delete possible existing Keep Worksheet.
    Application.DisplayAlerts = False
        On Error Resume Next
            ThisWorkbook.Worksheets(strSh).Delete
        On Error GoTo 0
    Application.DisplayAlerts = True
    ' Handle unexpected error.
    On Error GoTo ErrorHandler
    ' Copy Source Worksheet after itself.
    ws.Copy After:=ws
    ' Create a reference to the newly created Keep Worksheet, which is
    ' the ActiveSheet now.
    Set wsK = ActiveSheet
    ' In Keep Worksheet
    With wsK
        ' Rename Keep Worksheet to value (string) of Keep Worksheet Name
        ' Concatenator.
        .Name = strSh
        ' Calculate and clear rows below Keep Range.
        .Rows(NorK + cFR).Resize(.Rows.Count - NorK - cFR + 1).Clear
        ' Calculate and create a reference to Keep Range.
        Set rng = .Cells(cFR, FC).Resize(NorK, Noc)
        ' Copy Keep Array to Keep Range.
        rng = vntK
    End With
    Erase vntK ' No longer needed. Data in Keep Range.

    ' Task: Write from Source Array (vntS) to Unique Array (vntU).

    ' Caclulate Unique Number of Rows.
    NorU = dict.Count + 1 ' + 1 for Headers
    ' Resize Unique Array to Unique Number of Rows and Number of Columns.
    ReDim vntU(1 To NorU, 1 To Noc)
    ' Reset Unique Array Row Counter.
    k = 1
    ' Write Headers from Source Array to Unique Array.
    For j = 1 To Noc
        vntU(1, j) = vntS(1, j)
    Next
    ' Write Body Unique Values from Source array to Unique Array.
    For Each key In dict
        k = k + 1
        For j = 1 To Noc
            vntU(k, j) = vntS(dict(key), j)
        Next
    Next
    Erase vntS ' No longer needed. Data in Keep Range and Unique Array.
    dict.RemoveAll ' No longer needed. Data in Unique Array.

    ' Task: Copy Unique Array (vntU) to Unique Range (rng) in
    '       Source Worksheet (ws).

    ' In Source Worksheet
    With ws
        ' Calculate and clear rows below Unique Range.
        .Rows(NorU + cFR).Resize(.Rows.Count - NorU - cFR + 1).Clear
        ' Calculate and create a reference to Unique Range.
        Set rng = .Cells(cFR, FC).Resize(NorU, Noc)
        ' Copy Unique Array to Unique Range.
        rng = vntU
    End With
    Erase vntU ' No longer needed. Data is in Unique Range.

ProcedureExit:

    ' Speed Down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

UniqueMessage:
    MsgBox "All values are unique.", vbInformation, "Unique"
    GoTo ProcedureExit

ErrorHandler:
    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

Answer 3

尝试完成工作并尝试保持简单

Sub test()
Dim SrcRw As Long, SrclastRow As Long, SrcWs As Worksheet, TrgWs As Worksheet
Dim TrgRw As Long, TrglastRow As Long
Dim Animal As String, Rng As Range, C As Range, firstAddress As String

'Do
Set SrcWs = ThisWorkbook.Sheets(1)
SrcRw = 1
TrgRw = 1


Do While SrcWs.Cells(SrcRw, 3).Value <> ""
Animal = SrcWs.Cells(SrcRw, 3).Value
    With SrcWs.Range("C" & SrcRw + 1 & ":C" & Rows.Count)
    Set C = .Find(Animal, LookIn:=xlValues)

        If Not C Is Nothing Then
        firstAddress = C.Address
            Do
                If Rng Is Nothing Then
                Set Rng = C
                Else
                Set Rng = Union(Rng, C)
                End If
            'Debug.Print C.Address
            Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> firstAddress
        End If
    End With


    If Not Rng Is Nothing Then
    If TrgWs Is Nothing Then Set TrgWs = ThisWorkbook.Worksheets.Add(ThisWorkbook.Sheets(1))
    Rng.EntireRow.Copy TrgWs.Range("A" & TrgRw)
    TrgRw = TrgWs.Range("A" & TrgWs.Rows.Count).End(xlUp).Row + 1
    Rng.EntireRow.Delete
    End If
Set Rng = Nothing
SrcRw = SrcRw + 1
Loop

'    If TrgWs Is Nothing Then
'    Exit Sub
'    End If
'Set TrgWs = Nothing
'Loop

End Sub

该代码可以轻松按需运行一次，但是如果尝试循环生成新生成的图纸，则可能会崩溃，因为您的动物列表的长度可能超过数千行，而按10个动物的一组设置，则可能会增加100张图纸。因此，即使启用了标准计算事件屏幕更新后，如果启用了外部循环，它也有大约700行崩溃的趋势。

因此，尝试了另一种简单的解决方法，其中原始动物列表保持完整，并且每组唯一列表在第二张纸上输出，并且它们之间有空白行。在这里另一列说D在这里用来跟踪已经使用的列表。代码如下

Sub test2()
Dim SrcRw As Long, SrclastRow As Long, SrcWs As Worksheet, TrgWs As Worksheet
Dim TrgRw As Long, TrglastRow As Long, LoopNo As Long
Dim Animal As String, Rng As Range, C As Range, firstAddress As String
Dim AnimalCol As String, Dummy As Variant, Lcnt() As Long


Dummy = InputBox("Enter Column Letter,Source Sheet Name And Target Sheet Name seperated by Comma", "Input Source & targets", "C,Sheet1,Sheet2")
If Len(Dummy) <= 0 Then
MsgBox " Invalid input"
Exit Sub
Else
Dummy = Split(Dummy, ",")
    If UBound(Dummy) < 2 Then
    MsgBox " Invalid input, All parameters are not entered"
    Exit Sub
    End If
End If


AnimalCol = Dummy(0)
Set SrcWs = ThisWorkbook.Sheets(Dummy(1))
Set TrgWs = ThisWorkbook.Sheets(Dummy(2))
TrgRw = 1
LoopNo = 1
SrclastRow = SrcWs.Range("A" & SrcWs.Rows.Count).End(xlUp).Row + 1
ReDim Lcnt(1 To SrclastRow)

    For SrcRw = 1 To SrclastRow
    Lcnt(SrcRw) = 1
    Next

    Do
    Set Rng = Nothing
    SrcRw = 1
        Do While SrcWs.Cells(SrcRw, AnimalCol).Value <> ""
        If Lcnt(SrcRw) = LoopNo Then
        Animal = SrcWs.Cells(SrcRw, AnimalCol).Value

            If Rng Is Nothing Then
            Set Rng = SrcWs.Cells(SrcRw, 1)
            Else
            Set Rng = Union(Rng, SrcWs.Cells(SrcRw, 1))
            End If

        With SrcWs.Range(AnimalCol & SrcRw + 1 & ":" & AnimalCol & SrclastRow)
        Set C = .Find(Animal, LookIn:=xlValues)
            If Not C Is Nothing Then
            firstAddress = C.Address
                Do
                Lcnt(C.Row) = LoopNo + 1
                Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> firstAddress
            End If
       End With

       End If
       SrcRw = SrcRw + 1
       Loop

       If Not Rng Is Nothing Then
       Rng.EntireRow.Copy TrgWs.Range("A" & TrgRw)
       TrgRw = TrgWs.Range("A" & TrgWs.Rows.Count).End(xlUp).Row + 2
       Else
       Exit Do
       End If
    Set Rng = Nothing
    LoopNo = LoopNo + 1
    Loop

End Sub

代码2的结果

在列中查找重复的值，并将整行移动到新表

3 个答案:

独特的魔法

代码