[Solved] Problem with Micro
- Thread starter Haas
- Start date
- Status
Salam, Please solve the sheet. 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.
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
As a result, you will see an output like the following one.
Besides, I am also attaching the solution workbook for better understanding. Good luck!
Regards
Lutfor Rahman Shimanto
Last edited:
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 SubDon't hesitate to let me know if you need further assistance regarding this problem. Stay blessed!
Regards
Lutfor Rahman Shimanto
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
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
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 SubOUTPUT:
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 SubOUTPUT:
I have attached the solution workbook as well. Stay blessed, and good luck.
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
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
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
Dear HaasSalam, 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
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.
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 SubRequirement 2: You must run the StoreGapValuesWithColorBackground sub-routine in module.
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 SubLikewise, I am attaching the solution workbook. Good luck.
Regards
Lutfor Rahman Shimanto
- Status