Pivot数据

• IMO，你面临着一个XY问题，即。你使用列表框作为“中间人”来将源转向目的地。您应该通过简单地透视源数据来实现这一点。
  主要

Private Sub UserForm_Initialize()

    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Return the values from the source data range
    ' in the source data array ('sData').
    Dim sws As Worksheet: Set sws = wb.Sheets("Sheet5")
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion ' table
    Dim sdrg As Range
    Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1) ' data
    Dim sData() As Variant: sData = sdrg.Value
    
    ' Pass the source data array to the 'PopulateListbox' method (procedure).
    PopulateListbox sData
    
    ' Reference the destination table range (has headers).
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet9")
    Dim dtrg As Range: Set dtrg = dws.Range("A1").CurrentRegion ' table
    
    ' Pass the source data array and the destination table range
    ' to the 'PopulateSheet9' method (procedure).
    PopulateSheet9 sData, dtrg
    
End Sub

帮助-列表框

Sub PopulateListbox(Data() As Variant)

    With Me.ListBox1

        ' Do these 3 only once!
        .ColumnHeads = True
        .ColumnCount = 3
        .ColumnWidths = "75;75;75;75"

        Dim r As Long

        For r = 1 To UBound(Data, 1)
            .AddItem
            .List(r - 1, 0) = Data(r, 1)
            .List(r - 1, 1) = Data(r, 2)
            .List(r - 1, 2) = Format(Data(r, 3), "hh:mm:ss")
        Next r

    End With

End Sub

The Help - Pivot

• 请注意，一个更有效的解决方案是将Application.Match的“功能”替换为将月份和颜色写入字典，以便分别搜索列和行索引。

Sub PopulateSheet9(sData() As Variant, ByVal dtrg As Range)
    
    ' Determine the number of rows and columns
    ' of the destination values ('Time').
    Dim drCount As Long: drCount = dtrg.Rows.Count - 1
    Dim dcCount As Long: dcCount = dtrg.Columns.Count - 1
    
    ' Reference the 'elements' of the destination table.
    
    ' Column Labels
    Dim drgMonths As Range: Set drgMonths = dtrg.Resize(1, dcCount).Offset(, 1)
    ' Row Labels
    Dim drgColors As Range: Set drgColors = dtrg.Resize(drCount, 1).Offset(1)
    ' Values
    Dim drgValues As Range:
    Set drgValues = dtrg.Resize(drCount, dcCount).Offset(1, 1)
    
    ' Clear previuos values data.
    drgValues.ClearContents ' to preserve the 'Time' formatting (not '.Clear'!)
    
    ' Write the matching values to the destination values array.
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount) '
    ' In this case, the same as 'dData = drgValues.Value')
    
    Dim DateIndex As Variant, ColorIndex As Variant, sr As Long
    
    For sr = 1 To UBound(sData, 1)
        DateIndex = Application.Match(sData(sr, 1), drgMonths, 0)
        ColorIndex = Application.Match(sData(sr, 2), drgColors, 0)
        If IsNumeric(DateIndex) And IsNumeric(ColorIndex) Then
             dData(ColorIndex, DateIndex) = sData(sr, 3)
        End If
    Next sr

    ' Write the values from the destination array to the destination range.
    drgValues.Value = dData

End Sub

请试试下一条路。它使用数组，主要在内存中工作，即使在更大的范围内也很快：

Sub ExtractColorTime()
  Dim shT As Worksheet, rngHead As Range, rngCol As Range, lastR As Long
  Dim mtchR, mtchC, arr, arrLst, nT As Long, rngRet As Range
  
  Set shT = ThisWorkbook.Sheets("Sheet9")
  lastR = shT.Range("A" & shT.rows.count).End(xlUp).Row
  Set rngHead = shT.Range("B1:M1")       'headers range
  Set rngCol = shT.Range("A2:A" & lastR) 'colors range
  
  Set rngRet = shT.Range("B2:M" & lastR) 'the range where to return
  rngRet.ClearContents
  arr = rngRet.value 'place the range in an array to be returned at once
  
  arrLst = ListBox1.List 'place the list box intems in an array for faster processing
            
    For nT = 0 To UBound(arrLst) 'iterate between the list array rows
        mtchR = Application.match(arrLst(nT, 0), rngHead, 0) 'match the header column (month)
        mtchC = Application.match(arrLst(nT, 1), rngCol, 0)  'match the color row
        If IsNumeric(mtchR) And IsNumeric(mtchC) Then 'if buth matches exist:
            arr(mtchC, mtchR) = Format(arrLst(nT, 2), "hh:mm:ss") ' place the well formatted time in its correct position
        End If
    Next
    
    'drop the array content at once:
    rngRet.value = arr
    
    MsgBox "Ready..."
End Sub

试试看吧

Dim shT As Worksheet, cT As Range, cC As Range
    Set shT = ThisWorkbook.Sheets("Sheet9")
    Dim nT As Long
    shT.Range("B2:M1000").ClearContents
    For nT = 0 To Me.ListBox1.ListCount - 1
        'Locate month
        Set cT = shT.Range("1:1").Find(Me.ListBox1.List(nT, 0), , xlValues, xlWhole)
        'Locate color
        Set cC = shT.Range("A:A").Find(Me.ListBox1.List(nT, 1), , xlValues, xlWhole)
        If Not (cT Is Nothing Or cC Is Nothing) Then
            shT.Cells(cC.Row, cT.Column).Value = ListBox1.List(nT, 2)
            ' OR
            ' cT.Offset(cC.Row - 1, 0).Value = ListBox1.List(nT, 2)
        End If
    Next nT