Sub Macro1() Dim wsSource As Worksheet
Dim wstarget As Worksheet
Dim cl As Range
Dim lCol As Long
Dim lcols As Long
Dim sCriteria As String
Dim sEmployee As String
'Set variables here for easier coding
Set wsSource = Worksheets("Sheet3")
Set wstarget = Worksheets("Sheet4")
sCriteria1 = "H"
scriteria2 = "LT"
sEmployee = wstarget.Range("C6").Value
'Turn off screen updates for speed
Application.ScreenUpdating = False
'Restore the first row on the Target worksheet
With wsSource
.Range("A1:" & .Range("C1").End(xlToRight).Address).Copy
wstarget.Range("A1").PasteSpecial Paste:=xlPasteAll
End With
'Copy the desired row
With wsSource
For Each cl In .Range("B3:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
If cl.Value = sEmployee Then
wsSource.Rows(cl.Row).Copy
wstarget.Rows("2").PasteSpecial Paste:=xlValues
wstarget.Rows("2").PasteSpecial Paste:=xlFormats
Exit For
End If
Next cl
End With
'Kill all non "H" columns
With wstarget
lcols = .Range("C1").End(xlToRight).Column
For lCol = lcols To 4 Step -1
Select Case .Cells(2, lCol).Value
Case Is = sCriteria1, scriteria2
'Matches what we want, so leave it alone!
Case Else
.Columns(lCol).Delete
End Select
Application.StatusBar = "Revieiwing dates... " & Round((1 - (lCol / lcols)) * 100, 0) & "% complete..."
Next lCol
End With
'Turn off statusbar
Application.StatusBar = False
End Sub