Filter and update columns in excel with vba-CodePudding

I have four columns: Name, Code, Hired and Fired. The Value in the Code columns is unique. Someone can be hired and fired several times during the year, but I need only the first time that someone is hired and only the last time that someone is fired. Can I filter and update these columns using vba?

What I have are the values in columns from A to D. What I want are the values in columns from I to L.

CodePudding user response：

So, if you are not aware of how to write VBA Code, then you may try using Excel Formulas as well, however for the following formulas, you definitely need to have access either to O365 or O365 Insiders Beta Version

• Formula used in cell F2 to get the Unique Name & Codes,

=UNIQUE(A2:B20)

• Formula used in cell H2

=MINIFS(C2:C20,A2:A20,F2:F6,B2:B20,G2:G6)

• Formula used in cell I2

=MAXIFS(D2:D20,A2:A20,F2:F6,B2:B20,G2:G6)

Using LET() makes easier to read and understand,

• Formula used in cell F9

=LET(u,UNIQUE(A2:A20),
c,UNIQUE(B2:B20),
CHOOSE({1,2,3,4},u,c,
MINIFS(C2:C20,A2:A20,u,B2:B20,c),
MAXIFS(D2:D20,A2:A20,u,B2:B20,c)))

Using LAMBDA() Function to create a custom, reusable function and refer them by a friendly name, LAMBDA() Function used in Name Manager with a Defined Name as HireFire with syntax as

=HireFire(array,header)

Where,

HireFire = LAMBDA(array,header,
VSTACK(TAKE(header,1,4),
LET(a,INDEX(array,,1),
b,INDEX(array,,2),
c,INDEX(array,,3),
d,INDEX(array,,4),
u,UNIQUE(a),
uc,UNIQUE(b),
HSTACK(u,uc,
MINIFS(c,a,u,b,uc),
MAXIFS(d,a,u,b,uc)))))(A2:D20,A1:D1)

• Therefore, Formula used in cell F15

=HireFire(A2:D20,A1:D1)

Since you have not mentioned your Excel Version, it may happen you are using either Excel 2019 or 2016 or 2013 so on so forth, hence, alternatives shown below,

• Formula used in cell F2

=IFERROR(INDEX(A$2:A$20,MATCH(0,COUNTIF($F$1:F1,A$2:A$20),0)),"")

The above formula, is an array formula and needs to press CTRL SHIFT ENTER based on your Excel Versions,

• Formula used in cell G2

=IF($F2="","",VLOOKUP($F2,$A$2:$D$20,2,0))

• Formula used in cell H2 --> Applicable To Excel 2019 & Above

=MINIFS(C$2:C$20,$A$2:$A$20,$F2,$B$2:$B$20,$G2)

If not using either of the above version then,

=MIN(IF(($F2=$A$2:$A$20)*($G2=$B$2:$B$20),$C$2:$C$20,""))

Its an array formula, hence needs to press CTRL SHIFT ENTER and fill down!

• Formula used in cell I2 --> Applicable To Excel 2019 & Above

=MAXIFS(D$2:D$20,$A$2:$A$20,$F2,$B$2:$B$20,$G2)

If not using either of the above version then,

=MAX(IF(($F2=$A$2:$A$20)*($G2=$B$2:$B$20),$D$2:$D$20,""))

Its an array formula, hence needs to press CTRL SHIFT ENTER and fill down!

CodePudding user response：

Unique With Max and Min Using a Dictionary

Sub CreateHireFireReport()
    
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A1"
    Const uCol As Long = 2
    Const hCol As Long = 3
    Const fCol As Long = 4
    
    Const dName As String = "Sheet1"
    Const dFirstCellAddress As String = "I1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
    If srg.Rows.Count < 2 Then Exit Sub ' no data or just headers
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    
    Dim sData As Variant: sData = srg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim sr As Long
    
    For sr = 2 To srCount
        Key = sData(sr, uCol)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next sr
    If dict.Count = 0 Then Exit Sub ' only blanks and error values
    
    Dim drCount As Long: drCount = dict.Count   1
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    Dim ddr As Long: ddr = 1
    
    Dim dr As Long
    Dim c As Long
    
    ' Write headers.
    For c = 1 To cCount
        dData(1, c) = sData(1, c)
    Next c
    
    ' Write data.
    For sr = 2 To srCount
        Key = sData(sr, uCol)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                If dict(Key) = Empty Then
                    ddr = ddr   1
                    dr = ddr
                    dict(Key) = ddr
                    For c = 1 To cCount
                        dData(dr, c) = sData(sr, c)
                    Next c
                Else
                    dr = dict(Key)
                    If IsDate(sData(sr, hCol)) Then
                        If IsDate(dData(dr, hCol)) Then
                            If sData(sr, hCol) < dData(dr, hCol) Then
                                dData(dr, hCol) = sData(sr, hCol)
                            End If
                        Else
                            dData(dr, hCol) = sData(sr, hCol)
                        End If
                    End If
                    If IsDate(sData(sr, fCol)) Then
                        If IsDate(dData(dr, fCol)) Then
                            If sData(sr, fCol) > dData(dr, fCol) Then
                                dData(dr, fCol) = sData(sr, fCol)
                            End If
                        Else
                            dData(dr, fCol) = sData(sr, fCol)
                        End If
                    End If
                End If
            End If
        End If
    Next sr
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    With dws.Range(dFirstCellAddress).Resize(, cCount)
        ' Format unique column as text.
        .Resize(drCount, 1).Offset(, uCol - 1).NumberFormat = "@"
        ' Write result.
        .Resize(drCount).Value = dData
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - drCount   1).Offset(drCount).Clear
        ' Apply other formatting.
        .Font.Bold = True ' headers
        .EntireColumn.AutoFit
    End With

    MsgBox "Hire-fire-report created.", vbInformation
    
End Sub