Hi Haas,Salam, Brother Rahman
Thank you very much,for your EXPERT input, time and effort. I will check and let you how it come out
Regards to you, your team and family
Thanks, Take care. Love you all
Dear HaasSalam, Brother Rahman
Little problem needs another look at Sub StoreGapValuesWithColorBackground the result numbers do not match. PLEASE give another look
Thanks, Take Care. Love you all
Dear HaasSalam, Brother Rahman
Little problem needs another look at Sub StoreGapValuesWithColorBackground the result numbers do not match. PLEASE give another look
Thanks, Take Care. Love you all
Sub StoreGapValuesWithColorBackground()
Dim ws As Worksheet
Dim col As Range
Dim cell As Range
Dim colIndex As Integer
Dim gapCount As Integer
Dim lastGapRow As Long
Dim coloredCellFound As Boolean
Dim columnColor As Long
Dim lstGP As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim sourceData As Range
Dim lstRowSrc As Integer
Dim firstRowSrc As Integer
Dim rowSrc As Integer
Dim targetData As Range
Set sourceData = ws.Range("A14:H28")
Set targetData = ws.Range("S14:AA28")
firstRowSrc = sourceData.Cells(1, 1).Row
rowSrc = sourceData.Cells(sourceData.Rows.Count, 1).End(xlUp).Row
lstRowSrc = rowSrc - firstRowSrc + 1
Debug.Print lstRowSrc
gapCount = 0
For colIndex = 2 To sourceData.Columns.Count
Set col = ws.Range(sourceData.Cells(1, colIndex), sourceData.Cells(lstRowSrc, colIndex))
lastGapRow = 1
coloredCellFound = False
columnColor = -1
For Each cell In col
If Not IsEmpty(cell.Value) Then
If cell.Interior.Color <> RGB(255, 255, 255) Then
If gapCount > 0 Then
targetData.Cells(lastGapRow, colIndex - 1).Value = gapCount
gapCount = 0
lastGapRow = lastGapRow + 1
End If
coloredCellFound = True
Else
gapCount = gapCount + 1
End If
If columnColor = -1 And cell.Interior.Color <> RGB(255, 255, 255) Then
columnColor = cell.Interior.Color
End If
End If
Next cell
If Not coloredCellFound Then
targetData.Cells(lastGapRow, colIndex - 1).Value = 0
gapCount = 0
lastGapRow = lastGapRow + 1
ElseIf gapCount > 0 Then
targetData.Cells(lastGapRow, colIndex - 1).Value = gapCount
gapCount = 0
lastGapRow = lastGapRow + 1
End If
If columnColor <> -1 Then
ws.Range(targetData.Cells(1, colIndex - 1), targetData.Cells(lastGapRow - 1, colIndex - 1)).Interior.Color = columnColor
End If
Next colIndex
End Sub
Dear HaasSalam, Brother Rahman
Thank you. I will run it and let you know the outcome. How to change ? source on sheet1 and target on sheet 2 or sheet 3. This Gap sheet will be on sheet2 or sheet3.
Thanks for all the hard work. For you its easy, I tried to figure it out but unable to do so . Two more needs your expert attention, The Sine value and forecast. I know you are a very busy person. Allah SWT make you shine in both worlds, Ameen, InshaAllah
Take Care Regards to all
Sub CountColoredCellsWithColorBackground()
Dim ws1, ws3 As Worksheet
Dim col As Range
Dim cell As Range
Dim coloredCount As Integer
Dim targetColor As Long
Dim colIndex As Integer
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim sourceData As Range
Dim lstRowSrc As Integer
Dim targetData As Range
Set sourceData = ws1.Range("A14:H28")
Set targetData = ws3.Range("J14:P14")
lstRowSrc = sourceData.Cells(sourceData.Rows.Count, 1).End(xlUp).Row
coloredCount = 0
targetColor = -1
For colIndex = 2 To sourceData.Columns.Count
Set col = ws1.Range(sourceData.Cells(1, colIndex), sourceData.Cells(lstRowSrc, colIndex))
For Each cell In col
If Not IsEmpty(cell.Value) And cell.Interior.Color <> RGB(255, 255, 255) Then
coloredCount = coloredCount + 1
If targetColor = -1 Then
targetColor = cell.Interior.Color
End If
End If
Next cell
targetData.Cells(1, colIndex - 1).Value = coloredCount
If targetColor <> -1 Then
targetData.Cells(1, colIndex - 1).Interior.Color = targetColor
targetData.Cells(1, colIndex - 1).Font.Bold = True
End If
coloredCount = 0
targetColor = -1
Next colIndex
End Sub
Sub StoreGapValuesWithColorBackground()
Dim ws1, ws3 As Worksheet
Dim col As Range
Dim cell As Range
Dim colIndex As Integer
Dim gapCount As Integer
Dim lastGapRow As Long
Dim coloredCellFound As Boolean
Dim columnColor As Long
Dim lstGP As Integer
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim sourceData As Range
Dim lstRowSrc As Integer
Dim firstRowSrc As Integer
Dim rowSrc As Integer
Dim targetData As Range
Set sourceData = ws1.Range("A14:H28")
Set targetData = ws3.Range("S14:AA28")
firstRowSrc = sourceData.Cells(1, 1).Row
rowSrc = sourceData.Cells(sourceData.Rows.Count, 1).End(xlUp).Row
lstRowSrc = rowSrc - firstRowSrc + 1
Debug.Print lstRowSrc
gapCount = 0
For colIndex = 2 To sourceData.Columns.Count
Set col = ws1.Range(sourceData.Cells(1, colIndex), sourceData.Cells(lstRowSrc, colIndex))
lastGapRow = 1
coloredCellFound = False
columnColor = -1
For Each cell In col
If Not IsEmpty(cell.Value) Then
If cell.Interior.Color <> RGB(255, 255, 255) Then
If gapCount > 0 Then
targetData.Cells(lastGapRow, colIndex - 1).Value = gapCount
gapCount = 0
lastGapRow = lastGapRow + 1
End If
coloredCellFound = True
Else
gapCount = gapCount + 1
End If
If columnColor = -1 And cell.Interior.Color <> RGB(255, 255, 255) Then
columnColor = cell.Interior.Color
End If
End If
Next cell
If Not coloredCellFound Then
targetData.Cells(lastGapRow, colIndex - 1).Value = 0
gapCount = 0
lastGapRow = lastGapRow + 1
ElseIf gapCount > 0 Then
targetData.Cells(lastGapRow, colIndex - 1).Value = gapCount
gapCount = 0
lastGapRow = lastGapRow + 1
End If
If columnColor <> -1 Then
ws3.Range(targetData.Cells(1, colIndex - 1), targetData.Cells(lastGapRow - 1, colIndex - 1)).Interior.Color = columnColor
End If
Next colIndex
End Sub
Dear HaasSalam, Brother Rahman
Thank you. I will run it and let you know the outcome. How to change ? source on sheet1 and target on sheet 2 or sheet 3. This Gap sheet will be on sheet2 or sheet3.
Thanks for all the hard work. For you its easy, I tried to figure it out but unable to do so . Two more needs your expert attention, The Sine value and forecast. I know you are a very busy person. Allah SWT make you shine in both worlds, Ameen, InshaAllah
Take Care Regards to all
Sub CalculateForecastValues()
Dim sourceRange As Range
Dim targetRange As Range
Dim col As Long
Dim hiValue As Double
Dim midValue As Double
Dim lowValue As Double
Set sourceRange = Worksheets("Sheet2").Range("B43:H53")
Set targetRange = Worksheets("Sheet2").Range("M43:S47")
For col = 1 To sourceRange.Columns.Count
hiValue = WorksheetFunction.Max(sourceRange.Columns(col))
midValue = WorksheetFunction.median(sourceRange.Columns(col))
lowValue = WorksheetFunction.Min(sourceRange.Columns(col))
targetRange.Cells(1, col).Value = hiValue
targetRange.Cells(3, col).Value = midValue
targetRange.Cells(5, col).Value = lowValue
Next col
End Sub
Sub CalculateSineCurveValues()
Dim sourceRange As Range
Dim targetRange As Range
Dim col As Long
Dim row As Long
Dim amplitude As Double
Dim frequency As Double
Dim phaseShift As Double
Set sourceRange = Worksheets("Sheet2").Range("M43:S47")
Set targetRange = Worksheets("Sheet2").Range("X43:AF47")
amplitude = 10
frequency = 0.1
phaseShift = 0
For col = 1 To sourceRange.Columns.Count
For row = 1 To sourceRange.Rows.Count Step 2
targetRange.Cells(row, col).Value = amplitude * Sin(frequency * row + phaseShift) + sourceRange.Cells(row, col).Value
Next row
Next col
End Sub
Dear Haas,Salam, Brother Rahman
Thank you for everything. My brother is in ICU serious condition, Please pray for him his name is Laeeq. as soon i get chance i will check and let you know
thanks
Wa alaykumu s-salam HaasSalam, Brother Rahman
Thanks for your prayers. Laeeq went back to his Creator. Allah SWT Bless him with JanatulFirdose. Ameen
Wa alaykumu s-salam HaasSorry for not getting back to you and thanks for your kind prayer. I did not feel like doing any thing. How are you and your family?
Dear HaasI am attaching a .bas file for your kind, expert tweaking. This is a college project for my son, I am helping him. once upon a time, I use to be very good in excel & vba, but my mind dose not work any more.
Dear HaasSalam, Brother Rahman
Sorry for not getting back to you and thanks for your kind prayer. I did not feel like doing any thing. How are you and your family?
I am attaching a .bas file for your kind, expert tweaking. This is a college project for my son, I am helping him. once upon a time, I use to be very good in excel & vba, but my mind dose not work any more.
Thanks for you time and effort in solving these problems. Allah SWT will reward you for all the help you provide to people.
Take care
Sub CountAndColorCellsPQR()
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim cell As Range
Dim coloredCount As Integer
Dim columnCounter As Integer
Dim tempColor As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
columnCounter = 2
Do While columnCounter <= 233
coloredCount = 0
tempColor = RGB(255, 255, 255)
For Each cell In ws1.Range(ws1.Cells(7, columnCounter), ws1.Cells(6517, columnCounter))
If Not IsEmpty(cell.Value) And cell.Interior.Color <> RGB(255, 255, 255) Then
coloredCount = coloredCount + 1
If coloredCount = 1 Then
tempColor = cell.Interior.Color
End If
End If
Next cell
ws3.Cells(7, columnCounter - 1).Value = coloredCount
If tempColor <> RGB(255, 255, 255) Then
ws3.Cells(7, columnCounter - 1).Interior.Color = tempColor
End If
columnCounter = columnCounter + 1
Loop
End Sub
Sub StoreGapValuesWithColorBackground()
Dim ws1 As Worksheet
Dim ws4 As Worksheet
Dim col As Range
Dim cell As Range
Dim colIndex As Integer
Dim gapCount As Integer
Dim lastGapRow As Long
Dim coloredCellFound As Boolean
Dim columnColor As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws4 = ThisWorkbook.Sheets("Sheet4")
Dim sourceData As Range
Dim targetData As Range
Set sourceData = ws1.Range("B7:XH6517")
Set targetData = ws4.Range("B7:XH3000")
colIndex = 1
For Each col In sourceData.Columns
gapCount = 0
lastGapRow = 1
coloredCellFound = False
columnColor = RGB(255, 255, 255)
For Each cell In col.Cells
If Not IsEmpty(cell.Value) Then
If cell.Interior.Color <> RGB(255, 255, 255) Then
If coloredCellFound Then
targetData.Cells(lastGapRow, colIndex).Value = gapCount
lastGapRow = lastGapRow + 1
End If
coloredCellFound = True
gapCount = 0
columnColor = cell.Interior.Color
Else
gapCount = gapCount + 1
End If
End If
Next cell
If coloredCellFound Then
targetData.Cells(lastGapRow, colIndex).Value = gapCount
End If
targetData.Columns(colIndex).Interior.Color = columnColor
colIndex = colIndex + 1
Next col
End Sub
Wa alaykumu s-salam HaasSalam, Brother Rahman
Thank you very much for reply, I will let you know the result. Allah SWT have Blessed you with much of potential. keep it up and be thankful for every moment, you will shine like a star. InshaAllah
Thanks to you and your team for excellent work
Take Care
Dear HaasThank you very much for you time and effort. My son Noah have to submit the project by Oct 20th 2023. i know you are very busy person and I appreciate. the count of color cells worked fine. The problem is with the gap VBA, I am attaching the sheet for your consideration
Hello HaasSalam, Brother Rahman
Thank you very much for you time and effort. My son Noah have to submit the project by Oct 20th 2023. i know you are very busy person and I appreciate. the count of color cells worked fine. The problem is with the gap VBA, I am attaching the sheet for your consideration
Thank you again
Sub RStoreGapValuesWithColorBackground()
Dim ws1 As Worksheet
Dim ws4 As Worksheet
Dim col As Range
Dim cell As Range
Dim colIndex As Integer
Dim gapCount As Integer
Dim lastGapRow As Long
Dim coloredCellFound As Boolean
Dim columnColor As Long
Set ws1 = ThisWorkbook.Sheets("Test Source")
Set ws4 = ThisWorkbook.Sheets("Test Destination")
Dim sourceData As Range
Dim targetData As Range
Set sourceData = ws1.Range("B7:Z100")
Set targetData = ws4.Range("B7:Z110")
colIndex = 1
For Each col In sourceData.Columns
gapCount = 0
lastGapRow = 1
coloredCellFound = False
columnColor = RGB(255, 255, 255)
For Each cell In col.Cells
If Not IsEmpty(cell.Value) Then
If cell.Interior.Color <> RGB(255, 255, 255) Then
If coloredCellFound Then
If gapCount = 0 Then
targetData.Cells(lastGapRow, colIndex).Value = "R"
Else
targetData.Cells(lastGapRow, colIndex).Value = gapCount
End If
lastGapRow = lastGapRow + 1
End If
coloredCellFound = True
gapCount = 0
columnColor = cell.Interior.Color
Else
gapCount = gapCount + 1
End If
End If
Next cell
If coloredCellFound Then
If gapCount = 0 Then
targetData.Cells(lastGapRow, colIndex).Value = "R"
Else
targetData.Cells(lastGapRow, colIndex).Value = gapCount
End If
End If
targetData.Columns(colIndex).Interior.Color = columnColor
colIndex = colIndex + 1
Next col
End Sub