Snasui Excel Forum

Code: Select all

Sub Group()

        Dim rWs As Worksheet
        Dim tWs As Worksheet
        Dim tRange As Range
        Dim tAll As Range
        Dim lngLastRow As Long
        Dim lngNextRow As Long
        Dim strCon As String
        
        Set rWs = Sheets("Report")
        Set tWs = Sheets("Database")
        
        strCon = rWs.Range("E2")
        lngLastRow = tWs.Range("A" & Rows.Count).End(xlUp).Row
        Set tAll = tWs.Range("A2:A" & lngLastRow)
        lngNextRow = 4
        rWs.UsedRange.Offset(3, 0).ClearContents
        For Each tRange In tAll
            If tRange = strCon Then
                rWs.Range("A" & lngNextRow) = rWs.Range("A" & lngNextRow).Row - 3
                rWs.Range("B" & lngNextRow) = tRange.Offset(1, 0)
                rWs.Range("C" & lngNextRow) = tRange.Offset(2, 0)
                rWs.Range("D" & lngNextRow) = tRange.Offset(3, 0)
                rWs.Range("E" & lngNextRow) = tRange.Offset(4, 0)
                rWs.Range("F" & lngNextRow) = tRange.Offset(5, 0)
                rWs.Range("G" & lngNextRow) = tRange.Offset(6, 0)

            End If
            lngNextRow = rWs.Range("A" & Rows.Count).End(xlUp).Row + 1
        Next tRange
        
        
        Set rWs = Nothing
        Set tWs = Nothing
        Set tAll = Nothing
        
End Sub

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$2" And Target <> "" Then
        Group
    ElseIf Target.Address = "$E$2" And Target = "" Then
        MsgBox "Please select data."
    End If
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("Database")
        Set rAll = .Range("A2", .Range("A" & rl).End(xlUp))
    End With
    For Each r In rAll
        If r = Worksheets("Report").Range("E2") Then
            lng = lng + 1
            ReDim Preserve a(5, lng)
            a(1, lng) = lng
            a(2, lng) = r.Offset(0, 10)
            a(3, lng) = r.Offset(0, -9)
            a(4, lng) = r.Offset(0, -8)
            a(5, lng) = r.Offset(0, -7)
        End If
    Next r
    If lng > 0 Then
        With Worksheets("Report")
            Set rt = .Range("A4", .Range("G" & lng - 1 + 5))
            .Range("A4", .Range("A" & rl).End(xlUp).Offset(0, 4)).ClearContents
            .Range("A5:G5").Copy
            rt.PasteSpecial xlPasteFormats
            rt = Application.Transpose(a)
            .Range("D4", .Range("D" & rl).End(xlUp)).NumberFormat = "000000"
            .Range(.Range("A4").End(xlDown).Offset(1, 0), .Range("G" & rl)).Clear
            .Range("E2").Activate
        End With
    Else
        MsgBox "Data not found."
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub