Snasui Excel Forum

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$d$1" And Target <> "" Then
        showemp
    ElseIf Target.Address = "$d$1" And Target = "" Then
        MsgBox "Please select data."
    End If
End Sub

Code: Select all

Option Explicit
Option Base 1
Sub showemp()
    Dim a() As Variant, ing 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("dbberk")
        Set rall = .Range("F4", .Range("F" & rl).End(xlUp))
    End With
    For Each r In rall
        If r = Worksheets("find_deberk").Range("d1") Then
            ing = ing + 1
            ReDim Preserve a(5, ing)
            a(1, ing) = ing
            a(2, ing) = r.Offset(0, -5)
            a(3, ing) = r.Offset(0, -4)
            a(4, ing) = r.Offset(0, -3)
            a(5, ing) = r.Offset(0, -2)
        End If
    Next r
    If ing > 0 Then
        With Worksheets("find_deberk")
            Set rt = .Range("c4", .Range("f" & ing - 1 + 5))
            .Range("c4", .Range("c" & rl).End(xlUp).Offset(0, 4)).ClearContents
            .Range("c4:f4").Copy
            rt.PasteSpecial xlPasteFormats
            rt = Application.Transpose(a)
      '      .Range("B5", .Range("B" & rl).End(xlUp)).NumberFormat = "000000"
            .Range(.Range("c4").End(xlDown).Offset(1, 0), .Range("f" & rl)).Clear
            .Range("d1").Activate
        End With
    Else
        MsgBox "Data Not Found."
    End If
    Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub