Sort multiple "Sets" of data in multiple rows, by date

Question

I have 15 pieces of equipment that are tested and have their output recorded, so every 3 columns is a new "set" of test results. So I want each row to sort each set of data by Date, when I try including this in my program it either sorts all rows, doesn't sort accurately (dates still not linear), sorts just the dates and puts them together, etc. I'm kinda at a loss. Here is what the sheet looks like and code i'm using.

Desired layout example -

Tim Will 1st test -

Sub TransferData()

    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim searchValue As Long
    Dim lastRowSource As Long
    Dim i As Long
    Dim foundCell As Range
    Dim nextColumn As Long
    Dim isDuplicate As Boolean
    Dim valueJ As Double, valueP As Double, valueV As Double
    Dim valueL As Double, valueR As Double, valueX As Double
    Dim sheetNames As Variant
    Dim sheetName As Variant
    
    ' Set reference to the destination sheet (Amp dB Tracker)
    Set wsDest = ThisWorkbook.Sheets("Amp dB Tracker")
    
    ' List of source sheet names
    sheetNames = Array("GCS 003", "GCS 001", "GCS 002", "GCS 004", "GCS 005")
    
    ' Loop through each source sheet
    For Each sheetName In sheetNames
        ' Set the current source sheet
        Set wsSource = ThisWorkbook.Sheets(sheetName)
        
        ' Find the last row in the source sheet
        lastRowSource = wsSource.Cells(wsSource.Rows.Count, "I").End(xlUp).Row
        
        ' Loop through each row in the source sheet
        For i = 11 To lastRowSource ' Start from row 11 (assuming row 1 is headers)
            
            ' Check for numbers in column I (1 to 15)
            searchValue = wsSource.Cells(i, "I").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' Find the corresponding number in column C of "Amp dB Tracker"
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' Determine the next available column for that row (D, E, F, etc.)
                    nextColumn = 4 ' Start from column D (column 4)
                    
                    ' Loop to find the next available set of columns (D, E, F) in the row
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3 ' Move to the next set of columns (D, E, F)
                    Loop
                    
                    ' Check if this data already exists in the next available set of columns
                    isDuplicate = False
                    For j = 4 To nextColumn + 2 ' Check columns D, E, F (nextColumn to nextColumn+2)
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "J").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "L").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' If it's not a duplicate, copy the data
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' Date in next available D
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "J").Value ' Value from J in next available E
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "L").Value ' Value from L in next available F
                        
                        ' Check if the value from column J is between 20 and 24
                        valueJ = wsSource.Cells(i, "J").Value
                        If valueJ < 20 Or valueJ > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0) ' Highlight red
                        End If
                        
                        ' Check if the value from column L is between 36.53 and 38.13
                        valueL = wsSource.Cells(i, "L").Value
                        If valueL < 36.53 Or valueL > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0) ' Highlight red
                        End If
                    End If
                End If
            End If
            
            ' Check for numbers in column O (1 to 15)
            searchValue = wsSource.Cells(i, "O").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' Find the corresponding number in column C of "Amp dB Tracker"
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' Determine the next available column for that row (D, E, F, etc.)
                    nextColumn = 4 ' Start from column D (column 4)
                    
                    ' Loop to find the next available set of columns (D, E, F) in the row
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3 ' Move to the next set of columns (D, E, F)
                    Loop
                    
                    ' Check if this data already exists in the next available set of columns
                    isDuplicate = False
                    For j = 4 To nextColumn + 2 ' Check columns D, E, F (nextColumn to nextColumn+2)
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "P").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "R").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' If it's not a duplicate, copy the data
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' Date in next available D
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "P").Value ' Value from P in next available E
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "R").Value ' Value from R in next available F
                        
                        ' Check if the value from column P is between 20 and 24
                        valueP = wsSource.Cells(i, "P").Value
                        If valueP < 20 Or valueP > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0) ' Highlight red
                        End If
                        
                        ' Check if the value from column R is between 36.53 and 38.13
                        valueR = wsSource.Cells(i, "R").Value
                        If valueR < 36.53 Or valueR > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0) ' Highlight red
                        End If
                    End If
                End If
            End If
            
            ' Check for numbers in column U (1 to 15)
            searchValue = wsSource.Cells(i, "U").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' Find the corresponding number in column C of "Amp dB Tracker"
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' Determine the next available column for that row (D, E, F, etc.)
                    nextColumn = 4 ' Start from column D (column 4)
                    
                    ' Loop to find the next available set of columns (D, E, F) in the row
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3 ' Move to the next set of columns (D, E, F)
                    Loop
                    
                    ' Check if this data already exists in the next available set of columns
                    isDuplicate = False
                    For j = 4 To nextColumn + 2 ' Check columns D, E, F (nextColumn to nextColumn+2)
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "V").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "X").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' If it's not a duplicate, copy the data
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' Date in next available D
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "V").Value ' Value from V in next available E
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "X").Value ' Value from X in next available F
                        
                        ' Check if the value from column V is between 20 and 24
                        valueV = wsSource.Cells(i, "V").Value
                        If valueV < 20 Or valueV > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0) ' Highlight red
                        End If
                        
                        ' Check if the value from column X is between 36.53 and 38.13
                        valueX = wsSource.Cells(i, "X").Value
                        If valueX < 36.53 Or valueX > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0) ' Highlight red
                        End If
                    End If
                End If
            End If
            
        Next i
    Next sheetName

End Sub

Answer 1

Untested, but this is a shorter version (removed columns I O U duplications) which will sort the results as they're copied over (data being added to is assumed to be already sorted)

Option Explicit

Sub TransferData()
    
    'constants for summary sheet
    Const HEADER_ROW As Long = 2      'header row with background color set
    Const DATA_START_ROW As Long = 7  'row with first set of amp data
    Const AMP_ID_COL As Long = 3      'column with amp#
    Const COL_START As Long = 4       'first Date column in destination sheet
    
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim searchValue As Long
    Dim lastRowSource As Long
    Dim i As Long, nextColumn As Long
    Dim foundCell As Range
    Dim isDuplicate As Boolean
    Dim sheetNames As Variant, rwSrc As Range, rwDest As Range, cD As Range, rng As Range
    Dim sheetName As Variant, cols As Variant, col As Variant, dt, v1, v2, insCol As Long
    
    Set wsDest = ThisWorkbook.Sheets("Amp dB Tracker") ' Destination sheet
    sheetNames = Array("GCS 003", "GCS 001", "GCS 002", "GCS 004", "GCS 005") ' Source sheets
    cols = Array("I", "O", "U") ' Columns with equipment numbers
    
    For Each sheetName In sheetNames ' Loop through each source sheet
        Set wsSource = ThisWorkbook.Sheets(sheetName) ' Set current source sheet
        
        lastRowSource = wsSource.Cells(wsSource.Rows.Count, "I").End(xlUp).Row ' Last data row in column I
        For i = 11 To lastRowSource ' Start from row 11 (assuming row 1-10 is headers)
            Set rwSrc = wsSource.Rows(i)
            
            ' Check each of the specified columns for numbers between 1 and 15
            For Each col In cols
                searchValue = rwSrc.Columns(col).Value ' Get the number from column `col`
                If IsNumeric(searchValue) And searchValue >= 1 And searchValue <= 15 Then
                    ' Search for the value in the destination sheet
                    Set foundCell = wsDest.Columns(AMP_ID_COL).Find(searchValue, LookIn:=xlValues)
                    
                    If Not foundCell Is Nothing Then ' If match found
                        Set rwDest = foundCell.EntireRow ' Matched row in destination sheet
                        dt = rwSrc.Columns("A").Value ' Date in source sheet
                        v1 = rwSrc.Columns(col).Offset(0, 1).Value ' Corresponding number in next column
                        v2 = rwSrc.Columns(col).Offset(0, 3).Value ' Another corresponding number in another column
                        
                        Set cD = rwDest.Columns(COL_START) ' Start checking from first Date column in destination
                        isDuplicate = False ' Reset duplicate flag
                        insCol = 0 ' Reset insert position
                        
                        ' Check for duplicates and find an insert position
                        Do While Len(cD.Value) > 0
                            isDuplicate = (cD.Value = dt And _
                                           cD.Offset(0, 1).Value = v1 And _
                                           cD.Offset(0, 2).Value = v2)
                            If isDuplicate Then Exit Do ' Skip if duplicate found
                            
                            ' Find an insert position if data is newer
                            If insCol = 0 And cD.Value > dt Then insCol = cD.Column
                            Set cD = cD.Offset(0, 3) ' Move to next block of columns
                        Loop
                        
                        If Not isDuplicate Then ' If no duplicate, insert the data
                            If insCol > 0 Then ' If insert position found
                                rwDest.Columns(insCol).Resize(1, 3).Insert Shift:=xlToRight ' Shift existing data
                                Set cD = rwDest.Columns(insCol) ' Set new insert position
                            End If
                            ' Insert the date and the test values
                            cD.Value = dt
                            cD.Offset(0, 1).Value = v1
                            cD.Offset(0, 2).Value = v2
                            
                        End If ' End if not duplicate
                    End If ' End if match found
                End If ' End if number in range 1-15
            Next col ' Next equipment column
        Next i ' Next row
    Next sheetName ' Next source sheet
    
    'reformat the worksheet
    For i = DATA_START_ROW To wsDest.Cells(Rows.Count, AMP_ID_COL).End(xlUp).Row
        Set rng = wsDest.Cells(i, COL_START).Resize(1, 3) ' first data block
        Do While Application.CountA(rng) > 0
            'copy the fill color from the header row
            rng.Interior.Color = wsDest.Cells(HEADER_ROW, rng.Column).Interior.Color
            rng.Cells(1).NumberFormat = "dd/mm/yyyy" 'for example
            rng.Cells(2).Resize(1, 2).NumberFormat = "General"
            HighlightOutOfSpec rng.Cells(2), 20, 24       'flag any outliers
            HighlightOutOfSpec rng.Cells(3), 36.53, 38.13
            Set rng = rng.Offset(0, 3) 'next block over
        Loop
    Next i
    
End Sub

'set fill color for `c` to red if value is < `lowLimit` or > `highLimit`
Sub HighlightOutOfSpec(c As Range, lowLimit As Double, highLimit As Double)
    Dim v
    v = c.Value
    If v < lowLimit Or v > highLimit Then c.Interior.Color = vbRed
End Sub

Answer 2

So its not pretty but I was able to modify Tim Williams code (Thank you Tim very much for helping develop a better base). It is not pretty and it checks for the value ranges twice because after reformatting the cells it messed up the highlighting cells part, and when I tried removing the initial check it ended up breaking it... you get the idea. I am a novice and this is how I was able to brute force the result I wanted.

Many thanks again to Tim and Black Cat for helping me get this far, can't thank you enough!

Sub TransferData()
    Const COL_START As Long = 4 ' First Date column in destination sheet
    
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim searchValue As Long
    Dim lastRowSource As Long
    Dim i As Long, nextColumn As Long
    Dim foundCell As Range
    Dim isDuplicate As Boolean
    Dim sheetNames As Variant, rwSrc As Range, rwDest As Range, cD As Range
    Dim sheetName As Variant, cols As Variant, col As Variant, dt, v1, v2, insCol As Long
    
    Set wsDest = ThisWorkbook.Sheets("Amp dB Tracker") ' Destination sheet
    sheetNames = Array("GCS 003", "GCS 001", "GCS 002", "GCS 004", "GCS 005") ' Source sheets
    cols = Array("I", "O", "U") ' Columns with equipment numbers
    
    For Each sheetName In sheetNames ' Loop through each source sheet
        Set wsSource = ThisWorkbook.Sheets(sheetName) ' Set current source sheet
        
        lastRowSource = wsSource.Cells(wsSource.Rows.Count, "I").End(xlUp).Row ' Last data row in column I
        For i = 11 To lastRowSource ' Start from row 11 (assuming row 1-10 is headers)
            Set rwSrc = wsSource.Rows(i)
            
            ' Check each of the specified columns for numbers between 1 and 15
            For Each col In cols
                searchValue = rwSrc.Columns(col).Value ' Get the number from column `col`
                If IsNumeric(searchValue) And searchValue >= 1 And searchValue <= 15 Then
                    ' Search for the value in the destination sheet
                    Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                    
                    If Not foundCell Is Nothing Then ' If match found
                        Set rwDest = foundCell.EntireRow ' Matched row in destination sheet
                        dt = rwSrc.Columns("A").Value ' Date in source sheet
                        v1 = rwSrc.Columns(col).Offset(0, 1).Value ' Corresponding number in next column
                        v2 = rwSrc.Columns(col).Offset(0, 3).Value ' Another corresponding number in another column
                        
                        Set cD = rwDest.Columns(COL_START) ' Start checking from first Date column in destination
                        isDuplicate = False ' Reset duplicate flag
                        insCol = 0 ' Reset insert position
                        
                        ' Check for duplicates and find an insert position
                        Do While Len(cD.Value) > 0
                            isDuplicate = (cD.Value = dt And _
                                           cD.Offset(0, 1).Value = v1 And _
                                           cD.Offset(0, 2).Value = v2)
                            If isDuplicate Then Exit Do ' Skip if duplicate found
                            
                            ' Find an insert position if data is newer
                            If insCol = 0 And cD.Value > dt Then insCol = cD.Column
                            Set cD = cD.Offset(0, 3) ' Move to next block of columns
                        Loop
                        
                        If Not isDuplicate Then ' If no duplicate, insert the data
                            If insCol > 0 Then ' If insert position found
                                rwDest.Columns(insCol).Resize(1, 3).Insert Shift:=xlToRight ' Shift existing data
                                Set cD = rwDest.Columns(insCol) ' Set new insert position
                            End If
                            ' Insert the date, values, and apply color coding
                            cD.Value = dt
                            cD.Offset(0, 1).Value = v1
                            If v1 < 20 Or v1 > 24 Then cD.Offset(0, 1).Interior.Color = vbRed
                            cD.Offset(0, 2).Value = v2
                            If v2 < 36.53 Or v2 > 38.13 Then cD.Offset(0, 2).Interior.Color = vbRed
                        End If ' End if not duplicate
                    End If ' End if match found
                End If ' End if number in range 1-15
            Next col ' Next equipment column
        Next i ' Next row
    Next sheetName ' Next source sheet
    
    ' Change the number format of columns to "General"
    Dim colIdx As Long
    colIdx = 5 ' Start with column E (index 5)
    
    Do While colIdx <= wsDest.Cells(1, wsDest.Columns.Count).End(xlToLeft).Column
        If colIdx Mod 3 <> 0 Then ' Skip columns G, J, M, etc.
            wsDest.Columns(colIdx).NumberFormat = "General"
        End If
        colIdx = colIdx + 2 ' Move to the next pair (E/F -> H/I -> K/L, etc.)
    Loop
    
    ' Apply styles to cells starting from row 7
    Dim lastCol As Long
    lastCol = wsDest.Cells(8, wsDest.Columns.Count).End(xlToLeft).Column + 30 ' Find the last column in row 8 plus 30 columns as a buffer

    Dim startCol As Long
    startCol = 4 ' Start from column D (index 4)

    Dim styleIndex As Long
    styleIndex = 1 ' To switch between 20% Accent 1, 20% Accent 4, 20% Accent 6
    
    ' Loop through columns in steps of 3
    For colIdx = startCol To lastCol Step 3
        If colIdx + 2 <= lastCol Then
            ' Apply styles to D/E/F, G/H/I, J/K/L, etc.
            Select Case styleIndex
                Case 1
                    wsDest.Range(wsDest.Cells(7, colIdx), wsDest.Cells(wsDest.Rows.Count, colIdx + 2)).Style = "20% - Accent1"
                Case 2
                    wsDest.Range(wsDest.Cells(7, colIdx), wsDest.Cells(wsDest.Rows.Count, colIdx + 2)).Style = "20% - Accent4"
                Case 3
                    wsDest.Range(wsDest.Cells(7, colIdx), wsDest.Cells(wsDest.Rows.Count, colIdx + 2)).Style = "20% - Accent6"
            End Select
        End If
        
        ' Cycle through the styles
        styleIndex = styleIndex + 1
        If styleIndex > 3 Then styleIndex = 1 ' Reset to Accent 1 after Accent 6
    Next colIdx
    
' Check columns E, H, K, etc., for numbers outside the range 20-24, highlight red
Dim checkCol As Long
For checkCol = 5 To lastCol Step 3 ' Start from column E (index 5), check every 3rd column
    For rowIdx = 7 To 21 ' Check rows 7 to 21
        If Not IsEmpty(wsDest.Cells(rowIdx, checkCol).Value) Then ' Only check if cell is not empty
            If IsNumeric(wsDest.Cells(rowIdx, checkCol).Value) Then
                If wsDest.Cells(rowIdx, checkCol).Value < 20 Or wsDest.Cells(rowIdx, checkCol).Value > 24 Then
                    wsDest.Cells(rowIdx, checkCol).Interior.Color = vbRed ' Highlight cell red
                End If
            End If
        End If
    Next rowIdx
Next checkCol

' Check columns F, I, L, etc., for numbers outside the range 36.53-38.13, highlight red
For checkCol = 6 To lastCol Step 3 ' Start from column F (index 6), check every 3rd column
    For rowIdx = 7 To 21 ' Check rows 7 to 21
        If Not IsEmpty(wsDest.Cells(rowIdx, checkCol).Value) Then ' Only check if cell is not empty
            If IsNumeric(wsDest.Cells(rowIdx, checkCol).Value) Then
                If wsDest.Cells(rowIdx, checkCol).Value < 36.53 Or wsDest.Cells(rowIdx, checkCol).Value > 38.13 Then
                    wsDest.Cells(rowIdx, checkCol).Interior.Color = vbRed ' Highlight cell red
                End If
            End If
        End If
    Next rowIdx
Next checkCol
    
End Sub

Answer 3

This code creates a new sheet with the sorted data.

Sub sortbyrow()

Dim uns As Worksheet, srt As Worksheet
Set uns = Worksheets("Unsorted")
Set srt = Worksheets.Add
srt.Name = "Sorted"
uns.Cells.Copy srt.Cells
colblocks = (uns.Range("D2").End(xlToRight).Column - 3) / 3
maxrow = uns.Range("D2").End(xlDown).Row
For i = 2 To maxrow
    ReDim arr(1 To colblocks), block(1 To colblocks), neword(1 To colblocks)
    For j = 1 To colblocks
        arr(j) = uns.Cells(i, 1 + j * 3)
        block(j) = j
    Next j
    For j = 1 To colblocks
        neword(j) = WorksheetFunction.Match(WorksheetFunction.Min(arr), arr, 0)
        arr(neword(j)) = 100000
    Next j
    For j = 1 To colblocks
        srt.Range(srt.Cells(i, j * 3 + 1), srt.Cells(i, j * 3 + 3)).Value = uns.Range(uns.Cells(i, neword(j) * 3 + 1), uns.Cells(i, neword(j) * 3 + 3)).Value
    Next j
    
Next i


End Sub

Steps of the code

• Create a new sheet and copy/paste the unsorted data to it to keep color info.
• Define the rowblocks count and the last row of the data
• Sort a row based on the Date columns in neword array (contains block number)
• Copies the row values in sorted order to the new sheet.

With this parameter this works until date Thursday, October 14, 2173