[Solved] Problem with Micro
- Thread starter Haas
- Start date
- Status
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
Wa alaykumu s-salam! Thank you for your message! I truly appreciate your kind words. It's wonderful to hear that you found my input valuable.
Sending my regards to you and your family. Take care and stay well!
Best regards,
Lutfor Rahman Shimanto
Last edited:
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
I have reviewed the code and tested it several times. You are right about the raised issue. Currently, I am on to it. When I find a solution, I will share the idea in this thread.
Regards
Lutfor Rahman Shimanto
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
Thank you for being so patient and staying with ExcelDemy Forum. It's my bad! When modifying the code based on the Source and Target ranges, I failed to notice and change the lstRowSrc variable.
I am delighted to inform you that the below code will not disappoint you. I am attaching the solution workbook this time as well.
Excel VBA Code:
Code:
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 SubOUTPUT:
Stay blessed. Good luck.
Regards
Lutfor Rahman Shimanto
Salam, 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
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
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
Wa alaykumu s-salam! You are most welcome. You want to take the Source Data from Sheet1 and store Target Result on Sheet2 or Sheet3. To meet your new requirements, I have changed the previous code.
Source Data:
Requirement 1:
Code:
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 SubRequirement 2:
Code:
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 SubDownload the solution workbook for a better understanding. Good luck.
Regards
Lutfor Rahman Shimanto
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
I am sorry to inform you I cannot understand the problem regarding FORECASTING VALUES and SINE CURVE VALUES. I do not have the proper concept of how to calculate it manually. If I knew how to calculate these values mathematically, maybe I could develop the idea within Excel VBA. For now, I am giving you some codes that may help you.
FORECASTING VALUES:
Code:
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 SubSINE CURVE VALUES:
Code:
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 SubOUTPUT:
Please go through the attached file and let me know. Good luck.
Regards
Lutfor Rahman Shimanto
Dear Haas,
Wa alaykumu s-salam! I'm deeply sorry to hear about your brother Laeeq's current ICU condition. My thoughts and prayers are with you and your family during this challenging time. May Allah grant him a swift and complete recovery.
Take care
Lutfor Rahman Shimanto
Wa alaykumu s-salam Haas
I'm deeply saddened to hear about Laeeq's passing. May Allah SWT grant him a place in JanatulFirdose and provide comfort and strength to you and your family.
Ameen
Salam, 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
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
Attachments
Wa alaykumu s-salam Haas
It's great to hear from you again. No need to apologize at all! My family and I are doing well. Thank you for asking.
Currently, I am going through the specifications you have given in your attached file. When I am done, I will share my findings in this thread. Stay blessed!
Regards
Lutfor Rahman Shimanto
Dear Haas
I have reviewed the attached file you gave. After Investigating the file, I noticed that your requirements are below:
- Requirement 1: 232 Columns. and 6498 Rows of DATA. Digit length is 01 to 10,999. All calculations are done on each column
- Requirement 2: Ignore Blanks
- Requirement 3: Source DATA is on Sheet1
- Requirement 4: Colored Cells count & Forecast & Sine Curve is on Sheet3
- Requirement 5: Gaps of white cell count, Between the Colored cells is on Sheet4
I am going to provide the VBA codes in the next replies. Here, I have also attached the solution workbook. Good luck!
Download Solution Workbook
Regards
Lutfor Rahman Shimanto
Last edited:
Dear Haas
As requested, I am working with Source Data, which has 6498 rows and 232 columns. As a result, the execution time will be more than the usual running time.
1. RESULT OF SUM or COUNTS OF COLORED CELLS
Excel VBA Code:
Code:
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 Sub2. RESULT OF GAP or WHITE CELLS BETWEEN THE COLORED CELLS
Excel VBA Code:
Code:
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 SubGood luck!
Regards
Lutfor Rahman Shimanto
Salam, 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
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
Attachments
Wa alaykumu s-salam Haas
Thanks for your nice word. Your appreciation means a lot to us. May Allah bless you as well.
We are always here to assist. So do not hesitate to reach out any time.
Regards
Lutfor Rahman Shimanto
Dear Haas
Thanks for Thanking. After seeing the project, I will let you know whether I can do it alone or not.
Currently, I am going through the issue that arises with the sub-procedure responsible for calculating the Gap between the colored cells. When I am done, I will share the idea here.
Regards
Lutfor Rahman Shimanto
Hello Haas
I went through the attached file. You wanted to put R instead of 0 if there are no gaps between the colored cells. I have made a few changes to return R instead of 0 and overcome other issues.
RESULT OF GAP or WHITE CELLS BETWEEN COLORED CELLS
Excel VBA Code:
Code:
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 SubI am attaching the solution workbook as well. Good luck!
Download Workbook
Regards
Lutfor Rahman Shimanto
Last edited:
- Status