☰

从两组数据创建重复列表

tag-icon • tag-icon microsoft-excel vba macros
从两组数据创建重复列表

我有一份员工列表 (A1:A100) 和一份计划列表 (B1:B4)。我试图制作一份列表，将四项计划分别分配给每位员工，并将它们分别放在单独的单元格中，如下所示：

员工 1 计划 1
员工 1 计划 2
员工 1 计划 3
员工 1 计划 4
员工 2 计划 1
等等。

有没有我可以编写的宏，可以做到这一点而不需要大量复制和粘贴？我必须对一大堆这样的列表执行此操作。

答案1

排列两列

在此处输入图片描述

  • 这将返回独特的另一列中两列的值。
  • 调整常量部分的值。
Option Explicit

Sub PermutateTwoColumns()
    Const ProcName As String = "PermutateTwoColumns"
    On Error GoTo ClearError
    
    Const s1Name As String = "Sheet1"
    Const s1fcAddress As String = "A2"
    Const s2Name As String = "Sheet1"
    Const s2fcAddress As String = "B2"
    
    Const dName As String = "Sheet1"
    Const dfcAddress As String = "C2"
    Const Delimiter As String = " "
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the unique values from the columns to two dictionaries.
    Dim s1fCell As Range: Set s1fCell = wb.Worksheets(s1Name).Range(s1fcAddress)
    Dim dict1 As Object: Set dict1 = DictColumnRange(s1fCell)
    Dim s2fCell As Range: Set s2fCell = wb.Worksheets(s2Name).Range(s2fcAddress)
    Dim dict2 As Object: Set dict2 = DictColumnRange(s2fCell)
    
    Dim Data() As String: ReDim Data(1 To dict1.Count * dict2.Count, 1 To 1)
    
    Dim r As Long
    
    ' Write the permutations to a 2D one-based one-column array.
    Dim Key1 As Variant, Key2 As Variant
    For Each Key1 In dict1.Keys
        For Each Key2 In dict2.Keys
            r = r + 1
            Data(r, 1) = Key1 & Delimiter & Key2
        Next Key2
    Next Key1
    
    With wb.Worksheets(dName).Range(dfcAddress)
        ' Write from the array to the range.
        .Resize(r).Value = Data
        ' Clear below.
        .Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).Clear
    End With
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a one-column range, whose first
'               cell is defined by the first cell of a range ('FirstCell')
'               and whose last cell is the bottom-most non-empty cell
'               of the first cell's worksheet column, in a the keys
'               of a dictionary.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumnRange( _
    ByVal FirstCell As Range) _
As Object
    Const ProcName As String = "DictColumnRange"
    On Error GoTo ClearError
    
    ' Create a reference to the one-column range ('crg') whose first cell
    ' is defined by the first cell of the range ('FirstCell') and whose
    ' last cell is the bottom-most non-empty cell of the first cell's
    ' worksheet column.
    
    Dim crg As Range
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function ' no data in column
        Set crg = .Resize(lCell.Row - .Row + 1)
    End With

    ' Return the values of the column range ('crg')
    ' in a 2D one-based one-column array ('cData').
    
    Dim cData As Variant
    If crg.Rows.Count = 1 Then ' one cell
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = crg.Value
    Else ' multiple cells
        cData = crg.Value
    End If

    ' Return the unique values from the 2D one-based one-column array ('cData')
    ' in the keys of a dictionary ('dict'), error values and blanks excluded.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 1 To UBound(cData, 1)
        Key = cData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(CStr(Key)) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
   
    If dict.Count = 0 Then Exit Function ' only error values and blanks
        
    Set DictColumnRange = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

相关内容