[Solved] Problem with Micro

Status
Not open for further replies.
Salam, I am having problem in creating a Formula or a Micro, the Excel sheet is attached
I am new to Excel 365 and VBA

Thanks
Take care
Hello Haas

Thanks for reaching out and posting such an interesting problem. After investigating the workbook, I understand you want a VBA macro or formulas to solve your issue. I will introduce you to a sub-procedures named CompareAndCopy. The sub-procedure will compare values between two ranges called SOURCE DATA and TARGET DATA row-wise. Later, it will copy and paste the common data Format from the source to the target cells.

Steps:
First, navigate to Developer >> click on Visual Basic.
Open Visual Basic Editor.png

Due to this, VBA Editor will open. Later, hover over Insert >> click on Module >> paste the following code >> Run.
Code:
Sub CompareAndCopy()
    
    Dim ws As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim sourceCell As Range
    Dim targetCell As Range
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    For i = 15 To 29
        Set sourceRange = ws.Range("A" & i & ":H" & i)
        Set targetRange = ws.Range("P" & i & ":W" & i)
        
        For Each sourceCell In sourceRange
            For Each targetCell In targetRange
                If sourceCell.Value = targetCell.Value Then
                    sourceCell.Copy
                    targetCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
                End If
            Next targetCell
        Next sourceCell
    Next i
    
End Sub
Paste code in VBA Editor and Run.png

As a result, you will see an output like the following one.
OUTPUT.png

Besides, I am also attaching the solution workbook for better understanding. Good luck!

Regards
Lutfor Rahman Shimanto
 

Attachments

Last edited:
Salam, Brother Rahman, very good name. Thank you very much for your expert time and valuable input. I will try and let you know how it worked.
Thanks, Take Care and keep up the good work, it will help in both worlds
 
Salam, Brother Rahman, very good name. Thank you very much for your expert time and valuable input. I will try and let you know how it worked.
Thanks, Take Care and keep up the good work, it will help in both worlds
Dear Haas

Thank you once again for staying with ExcelDemy Forum. Your appreciation means a lot to us.

I forgot to provide you with the functionality that will ignore empty cells within the previous code. I am delighted to inform you that I have implemented the feature that will ignore blank cells. You must try the following code.
Code:
Sub CompareAndCopyIgnoringEmpty()
    
    Dim ws As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim sourceCell As Range
    Dim targetCell As Range
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    For i = 15 To 29
        Set sourceRange = ws.Range("A" & i & ":H" & i)
        Set targetRange = ws.Range("P" & i & ":W" & i)
        
        For Each sourceCell In sourceRange
            If Not IsEmpty(sourceCell.Value) Then
                For Each targetCell In targetRange
                    If Not IsEmpty(targetCell.Value) Then
                        If sourceCell.Value = targetCell.Value Then
                            sourceCell.Copy
                    targetCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
                        End If
                    End If
                Next targetCell
            End If
        Next sourceCell
    Next i
    
End Sub

Don't hesitate to let me know if you need further assistance regarding this problem. Stay blessed!

Regards
Lutfor Rahman Shimanto
 
Salam, Brother Rahman
Thank you very much for solving the problem. It worked excellent. I Prayed to Allah SWT to solve all of your and your family problems and shower His Blessings.
Thanks Again
Take Care and keep-up the good work. Returns are in many folds
 
Salam, Brother Rahman

You have written the VBA script so simple that I understood every line of it, Love it, job done very well. Thanks you very much
 
Salam, Brother Rahman
Thank you very much for solving the problem. It worked excellent. I Prayed to Allah SWT to solve all of your and your family problems and shower His Blessings.
Thanks Again
Take Care and keep-up the good work. Returns are in many folds
Wa alaykumu s-salam Brother Haas,

I hope this message finds you in the best of health and spirits. I am delighted to hear that my solution was effective and met your expectations. Your kind words and prayers mean a lot to me and my family. May Allah SWT accept your prayers and bless you abundantly as well.

Your appreciation and encouragement inspire us to continue our efforts and strive for excellence. We are always here to assist whenever you need help, so please don't hesitate to reach out at any time.

May Allah's blessings and mercy be upon you and your loved ones as well.

Warmest Regards,
Lutfor Rahman Shimanto
ExcelDemy
 
Salam, Brother Rahman

You have written the VBA script so simple that I understood every line of it, Love it, job done very well. Thanks you very much
Hello Haas,

I truly appreciate your kind words. It's lovely that the VBA script I provided was clear and understandable.

I went through your newly attached workbook. The problem seems to be interesting. It will take several hours to think about and implement the algorithm into a VBA sub-procedure. When I am done, I will share the idea within this thread. Meanwhile, stay with ExcelDemy Forum.

Thank you once again for your trust and appreciation. Good luck!

Regards,
Lutfor Rahman Shimanto
 
Salam, Brother Rahman

Thanks for all the assistance, need some more of your expertise. sheet is attached
Take care love you all.
Wa alaykumu s-salam! Haas. Thank you once again for bringing up such an interesting problem. After going through the workbook attached, I found there are two requirements. Fulfilling these requirements was challenging; however, it was fascinating indeed.

Requirement 1: You wanted to calculate the sum of colored cells in each source data column.

Excel VBA Code:
Code:
Sub CountColoredCellsWithColorBackground()
    
    Dim ws As Worksheet
    Dim col As Range
    Dim cell As Range
    Dim coloredCount As Integer
    Dim targetColor As Long
    Dim colIndex As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    coloredCount = 0
    targetColor = -1
    
    For colIndex = 2 To 8

        Set col = ws.Range(ws.Cells(14, colIndex), ws.Cells(28, 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
        
        ws.Cells(14, colIndex + 8).Value = coloredCount
        
        If targetColor <> -1 Then
            ws.Cells(14, colIndex + 8).Interior.Color = targetColor
            ws.Cells(14, colIndex + 8).Font.Bold = True
        End If
        
        coloredCount = 0
        targetColor = -1
    
    Next colIndex
    
End Sub

OUTPUT:

Requirement 2: You wanted to find the gap or white cells between two colored cells.

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")
    
    gapCount = 0
    
    For colIndex = 2 To 8
        Set col = ws.Range(ws.Cells(14, colIndex), ws.Cells(28, colIndex))
        lastGapRow = 14
        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
                        ws.Cells(lastGapRow, colIndex + 17).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
            ws.Cells(lastGapRow, colIndex + 17).Value = 0
            gapCount = 0
            lastGapRow = lastGapRow + 1
        ElseIf gapCount > 0 Then
            ws.Cells(lastGapRow, colIndex + 17).Value = gapCount
            gapCount = 0
            lastGapRow = lastGapRow + 1
        End If
        
        If columnColor <> -1 Then
            ws.Range(ws.Cells(14, colIndex + 17), ws.Cells(lastGapRow - 1, colIndex + 17)).Interior.Color = columnColor
        End If
    Next colIndex
    
End Sub

OUTPUT:

I have attached the solution workbook as well. Stay blessed, and good luck.

Regards
Lutfor Rahman Shimanto
 

Attachments

Salam, Brother Rahman
Thank you very very much for your time, effort and thoughtfulness. Highly Appreciated
I am having problems with two solution above, unable to change ranges and move the results to other sheet.
Is there any way to define or declare ranges of Column and Row of Source & Target in the beginning of script, like Dim cell RANGE as E38:N45 OR ROW NUMBER & COLUMN NUMBER. & SHEET INFORMATION.
Then the script will become very flexible and adaptable to change for me.

Thanks, Take Care. Give my regards to your team and family. Love you all
:love:
 
Salam, Brother Rahman
Hope and pray, you and your family are doing well
Thanks. Take care
Dear Haas,

Wa alaykumu s-salam! Thanks a ton for your kind words. Currently, I am working on the modification of the previous code. It will take half an hour to reach your goal.

Stay with ExcelDemy Forum.

Regards
Lutfor Rahman Shimanto
 
Salam, Brother Rahman
Thank you very very much for your time, effort and thoughtfulness. Highly Appreciated
I am having problems with two solution above, unable to change ranges and move the results to other sheet.
Is there any way to define or declare ranges of Column and Row of Source & Target in the beginning of script, like Dim cell RANGE as E38:N45 OR ROW NUMBER & COLUMN NUMBER. & SHEET INFORMATION.
Then the script will become very flexible and adaptable to change for me.

Thanks, Take Care. Give my regards to your team and family. Love you all
:love:
Dear Haas

Thank you for staying with ExcelDemy Forum. You asked to modify the previous code so that you can easily change the destination range if needed. I am delighted to inform you that I have modified the code as requested.

Requirement 1: You must run the sub-procedure named CountColoredCellsWithColorBackground written in module2.
Requirement 1 modified code.png

Excel VBA Code:
Code:
Sub CountColoredCellsWithColorBackground()

    Dim ws As Worksheet
    Dim col As Range
    Dim cell As Range
    Dim coloredCount As Integer
    Dim targetColor As Long
    Dim colIndex As Integer
        
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    Dim sourceData As Range
    Dim lstRowSrc As Integer
    Dim targetData As Range
    
    Set sourceData = ws.Range("A14:H28")
    Set targetData = ws.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 = ws.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: You must run the StoreGapValuesWithColorBackground sub-routine in module.
Requirement 2 modified code.png

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

Likewise, I am attaching the solution workbook. Good luck.

Regards
Lutfor Rahman Shimanto
 

Attachments

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:
 
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:
 
Salam, Brother Rahman
Attach picture X's needs your kind review
Thanks
 

Attachments

  • Gap X's having problem .jpg
    Gap X's having problem .jpg
    130.8 KB · Views: 7
Status
Not open for further replies.

Online statistics

Members online
0
Guests online
18
Total visitors
18

Forum statistics

Threads
371
Messages
1,623
Members
704
Latest member
Michael Mpofu
Back
Top