You are using an out of date browser. It may not display this or other websites correctly.

You should upgrade or use an alternative browser.

You should upgrade or use an alternative browser.

- Thread starter Haas
- Start date

- Status
- Not open for further replies.

Salam, Please solve the sheet. thanks, take careSalam, 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

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

Thanks for reaching out and posting such an interesting problem. After investigating the workbook, I understand you want a

First, navigate to

Due to this,

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

Last edited:

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

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

Wa alaykumu s-salam BrotherSalam, 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

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,

ExcelDemy

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

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

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

Regards,

Wa alaykumu s-salam!Salam, Brother Rahman

Thanks for all the assistance, need some more of your expertise. sheet is attached

Take care love you all.

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

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

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

Regards

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

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

DearSalam, Brother Rahman

Hope and pray, you and your family are doing well

Thanks. Take care

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

Regards

Dear

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 ofSource & Targetin 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.

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

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

- Status
- Not open for further replies.