Sub Leo()
Dim item(4) As String, destrange As Range, qtr As Integer, i As Integer, col As Long
col = Sheets("sheet1").UsedRange.Columns.Count
i = 0
qt = 0
With Sheets("Sheet1")
For x = 2 To col
For Each cl In Range(.Cells(2, x), .Cells(4, x))
If cl.Interior.ColorIndex = 3 Then
qtr = qtr + 1
item(0) = .Cells(1, x).Value
item(i + 1) = cl.Value
i = i + 1
End If
Next cl
If qtr > 0 Then
With Sheets("Sheet3")
Set destrange = .Cells.Find(What:=vbNullString, After:=Sheets("sheet3").Cells(1, 1), _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
.Cells(1, destrange.Column).Resize(UBound(item), 1) = Application.Transpose(item)
End With
qtr = 0
i = 0
End If
If qtr = 0 Then item(0) = "": item(1) = "": item(2) = "": item(3) = "": i = 0
Next x
End With
With Sheets("Sheet2")
col = Sheets("sheet2").UsedRange.Columns.Count
i = 0: qtr = 0
For x = 2 To col
For Each cl In Range(.Cells(2, x), .Cells(4, x))
If cl.Interior.ColorIndex = 3 Then
qtr = qtr + 1
item(0) = .Cells(1, x).Value
item(i + 1) = cl.Value
i = i + 1
End If
Next cl
If qtr > 0 Then
With Sheets("Sheet3")
Set destrange = .Cells.Find(What:=vbNullString, After:=Sheets("sheet3").Cells(8, 1), _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
.Range(destrange.Address).Resize(UBound(item), 1) = Application.Transpose(item)
End With
qtr = 0: i = 0
End If
If qtr = 0 Then item(0) = "": item(1) = "": item(2) = "": item(3) = "": i = 0
Next x
End With
End Sub
think the red change is it
Kind regards
Leo
Bookmarks