79466774

Date: 2025-02-25 13:50:45
Score: 1.5
Natty:
Report link

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

Finished Product

Reasons:
  • Blacklisted phrase (0.5): Thank you
  • Blacklisted phrase (0.5): thank you
  • Blacklisted phrase (0.5): thanks
  • Long answer (-1):
  • Has code block (-0.5):
  • Self-answer (0.5):
  • Low reputation (1):
Posted by: Breaker1crazy