Search code examples
excelvbaformslistboxspreadsheet

Sheet to ListBox1 to Another Sheet

There is a very simple ListBox1 that displays data from Sheet5. Along with the code for displaying data from Sheet5, is a code that saves data to another sheet (Sheet9). My problem is, putting the data on the right row and column as per ListBox1 display.

This is the image of ListBox1 display from Sheet5:

image 1

This is the Raw data image of Sheet5:

image 2

This is the Raw data text of Sheet5:

Month       || Color    || Time
August      || Red      || 0:00:12
August      || Blue     || 0:00:02
September   || Blue     || 0:00:03
October     || Yellow   || 0:01:00
October     || Green    || 0:00:10

This is the Raw image of Sheet9 (to where the ListBox1 data are saved [temporarily - because I have a desired Sheet9 output]):

image 3

This is my whole form code:

Option Explicit
Private Sub UserForm_Initialize()
With Worksheets("Sheet5")
    Dim c As Range
    Dim i As Long
    For Each c In .Range("A2:A100")
        With Me.ListBox1
            .ColumnHeads = True
            .ColumnCount = 3
            .ColumnWidths = "75;75;75;75"
            .AddItem
            .List(i, 0) = c
            .List(i, 1) = c.Offset(, 1)
            .List(i, 2) = Format(c.Offset(, 2), "hh:mm:ss")
            i = i + 1
        End With
    Next c
End With

    Dim shT As Worksheet, cT As Range
    Set shT = ThisWorkbook.Sheets("Sheet9")
    Dim nT As Long
    shT.Range("B2: M2").ClearContents
    shT.Range("B3: M3").ClearContents
    'shT.Range("B4: M4").ClearContents
    'shT.Range("B5: M5").ClearContents
            
    For nT = 1 To Me.ListBox1.ListCount - 1
        'LOCATE
        Set cT = shT.Range("1:1").Find(Me.ListBox1.List(nT, 0), , xlValues, xlWhole)
        If Not cT Is Nothing Then
            cT.Offset(1, 0).value = ListBox1.List(nT, 1)
            cT.Offset(2, 0).value = ListBox1.List(nT, 2)
        End If
    Next nT
End Sub

This is my current result for my code above. Red marks below are not displayed while green marks are displayed in ListBox1. Row 1 in this sheet is manually coded as well as Column A. This is not really my desired Sheet9 output. I am just showing the current output of the code I am using.

image 4

This is my desired output below as per ListBox1 display, is this possible? If this is, what should be changed in the code above to save in Sheet9 this way? Still Row 1 and Column A are manually coded (in other words, only the dynamic time will be saved in the sheet according to the correct month and color displayed from ListBox1):

image 5

Thank you so much in advance...

Solution

  • Please, try the next way. It uses arrays, working mostly in memory and being fast even for larger ranges:

    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