Sub RangeCopyPaste()
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
MyCount = 1
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, 1)
Set NewRange = Application.Union(NewRange, cell.Offset(0, 1))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("B3")
'--> Remove Duplicates
ActiveSheet.Range("B3:B2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, -2)
Set NewRange = Application.Union(NewRange, cell.Offset(0, -2))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("C3")
'--> Remove Duplicates
ActiveSheet.Range("C3:C2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, 2)
Set NewRange = Application.Union(NewRange, cell.Offset(0, 2))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("D3")
'--> Remove Duplicates
ActiveSheet.Range("D3:D2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, -3)
Set NewRange = Application.Union(NewRange, cell.Offset(0, -3))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("E3")
'--> Remove Duplicates
ActiveSheet.Range("E3:E2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, 4)
Set NewRange = Application.Union(NewRange, cell.Offset(0, 4))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("F3")
'--> Remove Duplicates
ActiveSheet.Range("F3:2000").RemoveDuplicates
End Sub