79466774
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
- 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):
