[Solved] Problem with Micro

Status
Not open for further replies.
Haas said:
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 :love::love::love:
Click to expand...
Hi Haas,

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:
Haas said:
Salam, 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 :love::love::love:
Click to expand...
Dear Haas

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
 
Haas said:
Salam, 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 :love::love::love:
Click to expand...
Dear Haas

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 Sub

OUTPUT:
Hass (OUTPUT).png​

Stay blessed. Good luck.

Regards
Lutfor Rahman Shimanto
 

Attachments

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
:love::love::love:(y)(y)(y)
 
Haas said:
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
:love::love::love:(y)(y)(y)
Click to expand...
Dear Haas

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:
Source Data.png​

Requirement 1:
Requirement1 (SOLVED).png​

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 Sub

Requirement 2:
Requirement2 (SOLVED).png​

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 Sub

Download the solution workbook for a better understanding. Good luck.

Regards
Lutfor Rahman Shimanto
 

Attachments

Haas said:
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
:love::love::love:(y)(y)(y)
Click to expand...
Dear Haas

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 Sub

SINE 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 Sub

OUTPUT:
Demo OUTPUT.png​

Please go through the attached file and let me know. Good luck.

Regards
Lutfor Rahman Shimanto
 

Attachments

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
 
Haas said:
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
Click to expand...
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
 
Haas said:
Salam, Brother Rahman
Thanks for your prayers. Laeeq went back to his Creator. Allah SWT Bless him with JanatulFirdose. Ameen
Click to expand...
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
 

Attachments

Haas said:
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?
Click to expand...
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
 
Haas said:
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.
Click to expand...
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 modified the previously provided sub-procedures in such a way that fulfils all the requirements except for the Forecast and Sine curve. As mentioned earlier, I have no clue about how to solve the Forecast and Sine Curve problems manually. You must provide more resources for me to study and understand the problem. Later, I will try to develop an Excel VBA procedure to solve these particular problems.

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:
Haas said:
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
Click to expand...
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 Sub

2. 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 Sub

Good luck!

Regards
Lutfor Rahman Shimanto
 
Salam, 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
 
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
 

Attachments

Haas said:
Salam, 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
Click to expand...
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
 
Haas said:
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
Click to expand...
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
 
Haas said:
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
Click to expand...
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 Sub

I am attaching the solution workbook as well. Good luck!

Download Workbook

Regards
Lutfor Rahman Shimanto
 
Last edited:
Status
Not open for further replies.

Online statistics

Members online
1
Guests online
5
Total visitors
6
Totals may include hidden visitors.

Forum statistics

Threads
385
Messages
1,686
Members
731
Latest member
want2learn

Share this page

Back
Top