选择下一个唯一值

Question

我想将数据从一列复制到另一张纸上的列。

第一张纸上有一个ID号列表（从F3开始），紧挨着时钟的进出时间。 在转移到下一位雇员之前，将有5到31个ID号条目。

第二页是一个每天有一行的时间表。 每位员工的第一行都是空白（从C8开始），该行的数据余额（姓名，行业，场所等）是对此空白单元格的引用。 在第二页上，每位员工将有29至31行，以允许该月的所有日历天。

我正在尝试在第一张纸上搜索下一个唯一ID，然后将该值复制到第二张纸上的下一个可用空白单元格。

当我在工作表之间进行引用并填写第一个值时，我拥有的代码可以正常工作。 选择下一个唯一值，然后循环播放到列表末尾使我难以理解。

电子表格的图片： https : //www.dropbox.com/s/vg08uxb9kma2tza/VBA%20Help.jpg?dl=0

Sub TimesheetID()

ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
FinalRow = Cells(Rows.Count, 2).End(xlUp).Row

Worksheets("All Go").Activate

Range("E3").Select
Selection.Copy

Worksheets("Timesheet").Activate

Range("C7").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection.Font
    .Name = "Arial"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlBottom
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select

Worksheets("All GO").Activate

GoAgain:
    ThisRow = ThisRow + 1
    If ThisRow > Application.Rows.Count Then
        Cells(ThisRow - 1, ThisCol).Select
        Beep
        Exit Sub
    End If
    If Cells(ThisRow, ThisCol).Value = ThisVal Then
        GoTo GoAgain
    Else
        Cells(ThisRow, ThisCol).Select
    End If

ActiveCell.Select
Selection.Copy

Worksheets("Timesheet").Activate

ActiveSheet.Paste
 Application.CutCopyMode = False
With Selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection.Font
    .Name = "Arial"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlBottom
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With 

End Sub

Answer 1

本示例使用两个字典和Dictionary.Exists方法创建一个范围为A1：A50的唯一值数组。

Option Explicit

Sub UniqueList()

    Dim UniqueDic As Object

    Dim AllDic As Object 

    Dim rng As Range 

    Dim c As Range 

    Dim UniqueArray() As Variant

    Set UniqueDic = CreateObject("Scripting.Dictionary") 

    Set AllDic = CreateObject("Scripting.Dictionary")

    Set rng = ActiveSheet.Range("$A$1:$A50") 

    For Each c In rng.Cells

        If Not AllDic.Exists(c.Value2)

            UniqueDic.Add c.Value2, c.Row 

            AllDic.Add c.Value2, c.Row

        Else

            If Not UniqueDic.Exists(c.Value2) Then 

                UniqueDic.Remove c.Value2

            End If

        End If

    Next

    UniqueArray() = Array(UniqueDic.Keys)

End Sub

如果遍历一个范围并且当Not AllDic.Exists Cell.Value值为true时，字典“ AllDic”将获得一个等于单元格值的键； 那么AllDic.Keys将返回“ AllDic”唯一的值数组，但不一定是该范围唯一的值数组。

如果在Not AllDic.Exists Cell.Value值为真时使用“ AllDic”和“ UniqueDic”这两个字典，则它们都获得相同的键，但是如果为false，则当“ Not UniqueDic.Exists Cell.Value “ UniqueDic”时，它们将丢失键Not UniqueDic.Exists Cell.Value是真实的； 然后来自两个字典的键将返回具有唯一值的数组，但是，“ UniqueDic”将没有任何在该范围内重复的值。

Answer 2

我设法解决这个问题：

 Sub TDSFillTest()

Dim BadgeNo As Integer
Dim BlankCount As Integer
Dim LoopCount As Integer

LoopCount = 1

ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column

Worksheets("Timesheet").Activate 'Go to Timesheet and count blank cells
BlankCount = Range(("C8"), Cells(Rows.Count, 2).End(xlUp)).Cells.SpecialCells(xlCellTypeBlanks).Count

Worksheets("All Go").Activate 'Starting Point

Range("F3").Copy Worksheets("Timesheet").Range("C8") 'First Value to Timesheet

Worksheets("All Go").Activate ' Return to TDS
Range("F3").Select

Do Until LoopCount > BlankCount

    Worksheets("All Go").Activate

     Do
        ActiveCell.Offset(1, 0).Select
        If ActiveCell.Value <> ActiveCell.Offset(-1, 0).Value Then Exit Do
    Loop

    ActiveCell.Copy

    Worksheets("Timesheet").Activate

    ActiveCell.Offset(1, 0).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select

    ActiveSheet.Paste

    LoopCount = LoopCount + 1

Loop

End Sub

我将详细介绍您的内容，以便我可以学习更有效的方法。 谢谢！