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
Hello HaasSalam, 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
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
Dear HaasSalam, 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
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
Wa alaykumu s-salam Brother Haas,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
Hello Haas,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
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.Salam, Brother Rahman
Thanks for all the assistance, need some more of your expertise. sheet is attached
Take care love you all.
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
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
Dear Haas,Salam, Brother Rahman
Hope and pray, you and your family are doing well
Thanks. Take care
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
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
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