Excel Forum

Code: Select all

Sub ShowEmp()
    Dim a() As Variant, lng As Long
    Dim r As Range, rAll As Range
    Dim rt As Range, rl As Long
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    rl = Rows.Count
    With Worksheets("Data Return")
      Set rAll = .Range("C2", .Range("C" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("From Return").Range("B3") Then
            lng = lng + 1
            ReDim Preserve a(5, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, 2)
            a(3, lng) = r.Offset(0, 3)
            a(4, lng) = r.Offset(0, 4)
            a(5, lng) = r.Offset(0, 6)
        End If
    Next r
    If lng > 0 Then
        With Worksheets("From Return")
        Set rt = .Range("A6", .Range("E" & lng - 1 + 3))
            If .Range("A5") <> "" Then
              .Range("A6:E6", Selection.End(xlDown)).ClearContents
            End If
        
        .Range("A6:E6").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("A6:E6").End(xlDown).Offset(1, 0).ClearContents
      End With
    Else
      MsgBox "Data not found."
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub ShowEmp()
    Dim a() As Variant, lng As Long
    Dim r As Range, rAll As Range
    Dim rt As Range, rl As Long
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    rl = Rows.Count
    With Worksheets("Data Return")
      Set rAll = .Range("C2", .Range("C" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("From Return").Range("B3") Then
            lng = lng + 1
            ReDim Preserve a(5, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, 2)
            a(3, lng) = r.Offset(0, 3)
            a(4, lng) = r.Offset(0, 4)
            a(5, lng) = r.Offset(0, 6)
        End If
    Next r
    If lng > 0 Then
        With Worksheets("From Return")
        Set rt = .Range("A6", .Range("E" & lng - 1 + 5))
            If .Range("A6") <> "" Then
              .Range("A6", .Range("E6").End(xlDown)).ClearContents
            End If
        .Range("A6:E6").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
      End With
    Else
      MsgBox "Data not found."
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub