• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Convert equations to code (Attendance & Leave Timing)

H

Hany ali

Active Member
hello every body,good evening
i want your helps to Convert equations to code from Report's Sheet
Because the file became heavy because it is an array equations
this one for get Dates without Duplicate with Emplees's ID
Code: 
IFERROR(IF(AND(INDEX(Sheet1!$H$2:$H$2000, MATCH(0 &$B$1,COUNTIF($B$4:B4, Sheet1!$H$2:$H$2000) & Sheet1!$E$2:$E$2000, 0))>=$F$1,INDEX(Sheet1!$H$2:$H$2000, MATCH(0 &$B$1,COUNTIF($B$4:B4, Sheet1!$H$2:$H$2000) & Sheet1!$E$2:$E$2000, 0))<=$H$1),INDEX(Sheet1!$H$2:$H$2000, MATCH(0 &$B$1,COUNTIF($B$4:B4, Sheet1!$H$2:$H$2000) & Sheet1!$E$2:$E$2000, 0)),""),"")
And Another one for Get Differant attendence & Leave time in the same Date
Code: 
=IFERROR(INDEX(Sheet1!$I$2:$I$2000,MATCH(1,(Sheet1!$H$2:$H$2000=$B5)*(Sheet1!$E$2:$E$2000=$B$1)*(Sheet1!$L$2:$L$2000=C$4),0)),"")
 

Attachments

  • Attendance & Leave.xlsm
    357.5 KB · Views: 2
Your workbook is password protected. While I could easily break it, it is best to post workbooks without passwords or tell it to us.

I need to look at sheet1 data to see what all is going on.
 
sorry mr Kenneth ,i didn't post any file yet with password or protect
the file again
 

Attachments

  • Attendance & Leave.xlsm
    340.2 KB · Views: 4
Does your Report sheet look right? It should be getting dates up to May 2019 too? It just shows dates in Dec-2019.

Normally, I would use Advanced Filter or AutoFilter to do this sort of thing. Due to the formula on Sheet1, that makes it filter slow. Arrays would probably be best for speed.
 
Your files have nothing to do with how fast arrays are. If you meant formula arrays, that is the reason for your post I would guess. They can seem slower since they are usually coded for more data than what exists.

Since you did not answer my questions, I guess that your formulas are doing what you expect.

In this autofilter method, the speed is about twice as fast. Even so, 15s is somewhat long. Speed may be improved by adding more array methods and maybe by use of Advanced Filter.

Always test on backup copy. Right click the Report sheet, View Code, and paste:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("B1,F1,H1"), Target) Is Nothing Then UpdateReport
End Sub

In a Module:
Code: 
Sub UpdateReport()
    Dim ws1 As Worksheet, ws2 As Worksheet, rR As Range, rWS As Range
    Dim rIO As Range, r As Long, c As Integer, rw As Long
    Dim aD, i As Integer
    
    Set ws1 = Worksheets("report")
    Set ws2 = Worksheets("Sheet1")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "Updating Report Data..."
    
    'Clear contents of report data
    Set rR = Intersect(ws1.Rows("5:" & Rows.Count), ws1.UsedRange)
    rR.ClearContents
    'Get report column inout headings
    Set rIO = Range("C4", Range("C4").End(xlToRight))
    
    'Columns of data to search/filter
    'Set rWS = Intersect(ws2.UsedRange, ws2.Range("E:E,H:I,L:L"))
    Set rWS = Intersect(ws2.UsedRange, ws2.Columns("A:L"))

    With rWS
        'Array of unique dates in range of report
        .AutoFilter 8, ">=" & ws1.Range("F1"), xlAnd, "<=" & ws1.Range("H1")
        Set rR = Intersect(.Offset(1).SpecialCells(xlCellTypeVisible), ws2.Columns(8))
        aD = UniqueArrayByDict(rR.Value)
        'Array to hold matching data for report
        ReDim a(1 To UBound(aD) + 1, 1 To rIO.Columns.Count + 2)
        
        'Filter and fill array a
        .AutoFilter 5, ws1.Range("B1")  'ID?
        For r = 1 To UBound(aD) + 1
            .AutoFilter 8, aD(r - 1)    'Unique Dates
            Set rR = Intersect(.Offset(1).SpecialCells(xlCellTypeVisible), rWS)
            If Not rR Is Nothing Then
                rw = rw + 1
                a(rw, 1) = ws1.Range("B1")
                a(rw, 2) = aD(r - 1)
            End If
            For c = 1 To rIO.Columns.Count
                .AutoFilter 12, rIO.Cells(c)  'In or Out
                Set rR = Intersect(.Offset(1).SpecialCells(xlCellTypeVisible), rWS)
                If Not rR Is Nothing Then a(rw, c + 2) = rR.Cells(1, 9)
            Next c
            .AutoFilter
        Next r
    End With
    
    'Add filtered data to report
    ws1.Range("A5").Resize(UBound(a, 1), UBound(a, 2) + 1) = a
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = "Update Complete!"
    Application.Wait Now + TimeValue("00:00:01")
    Application.StatusBar = ""
End Sub

Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function
 
thanks alot for this code ,but when i make Run For The Code it stop to Done any thing , it stop in this row
Code: 
AutoFilter 12, rIO.Cells(c)  'In or Out
Sorry ,I want the Format for extract data As Time not Numbers
I Don't Know What the Problem ?
 

Attachments

  • Untitled.png
    Untitled.png
    114.5 KB · Views: 6
  • 1.png
    1.png
    156.4 KB · Views: 5
  • 2.png
    2.png
    178.6 KB · Views: 6
Last edited:
I took your file and deleted the array formulas on Report sheet. I did not change your number formats.

Another problem with using array formulas is that you have to manually set the number formats for all the cells that "might" get data. That can increase file size or result in some cells not getting the formats desired if not set.

As I asked in #4, does your array formula method on Report sheet even do what you wanted?

For my method, times increase as number of matched dates and "ID"s increases. Time is also increased when the array formulas are used on Sheet1. I included some time run data and a macro to do your own time runs. Change Sheet1 name to something else and the formula Sheet1 back to Sheet run to see the difference if you don't believe me. The fastest run times are for the Sheet1 with no array formulas.

I would suggest that you change your macro to hard code the values rather than leaving array formulas on Sheet1. That macro is slow.

Here is the code that I tweaked to do what I think that you want. You can change the formats to suit near the end of UpdateReport(). I attached the file as well.

Code: 
Sub UpdateReport()
    Dim ws1 As Worksheet, ws2 As Worksheet, rR As Range, rWS As Range
    Dim rIO As Range, r As Long, c As Integer, rw As Long
    Dim aD, i As Integer, a
   
    Set ws1 = Worksheets("report")
    Set ws2 = Worksheets("Sheet1")
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "Updating Report Data..."
   
    'Clear contents of report data
    Set rR = Intersect(ws1.Rows("5:" & Rows.Count), ws1.UsedRange)
    rR.ClearContents
    'Get report column inout headings
    Set rIO = Range("C4", Range("C4").End(xlToRight))
   
    'Columns of data to search/filter
    'Set rWS = Intersect(ws2.UsedRange, ws2.Range("E:E,H:I,L:L"))
    Set rWS = Intersect(ws2.UsedRange, ws2.Columns("A:L"))

    With rWS
        '.AutoFilter 5, ws1.Range("B1")  'ID?
        .AutoFilter 1, ws1.Range("B1")  'ID?
        'Array of unique dates in range of report
        .AutoFilter 8, ">=" & ws1.Range("F1"), xlAnd, "<=" & ws1.Range("H1")
        Set rR = Intersect(.Offset(1).SpecialCells(xlCellTypeVisible), ws2.Columns(8))
        aD = UniqueArrayByDict(RangeTo1dArray(rR))
        'Array to hold matching data for report
        ReDim a(1 To UBound(aD) + 1, 1 To rIO.Columns.Count + 2)
        .AutoFilter
       
        For r = 1 To UBound(aD) + 1
            'Filter and fill array a
            '.AutoFilter 5, ws1.Range("B1")  'ID?
            .AutoFilter 1, ws1.Range("B1")  'ID?
            .AutoFilter 8, aD(r - 1)    'Unique Dates
            Set rR = Intersect(.Offset(1).SpecialCells(xlCellTypeVisible), rWS)
            If Not rR Is Nothing Then
                rw = rw + 1
                a(rw, 1) = ws1.Range("B1")
                a(rw, 2) = aD(r - 1)
            End If
            For c = 1 To rIO.Columns.Count
                .AutoFilter 12, rIO.Cells(c)  'In or Out
                Set rR = Intersect(.Offset(1).SpecialCells(xlCellTypeVisible), rWS)
                If Not rR Is Nothing Then a(rw, c + 2) = rR.Cells(1, 9)
            Next c
            .AutoFilter
        Next r
    End With
   
    'Add filtered data to report
    With ws1.Range("A5").Resize(UBound(a, 1), UBound(a, 2))
        .Value = a
        .Columns("C:Z").NumberFormat = "hh:mm"
        .Columns("A").NumberFormat = "General"
        .Columns("B").NumberFormat = "mm/dd/yyyy"
    End With
   
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = "Update Complete!"
    Application.Wait Now + TimeValue("00:00:01")
    Application.StatusBar = ""
End Sub

Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant

  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2

  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

Function RangeTo1dArray(aRange As Range) As Variant
  Dim a() As Variant, c As Range, i As Long
  ReDim a(0 To aRange.Cells.Count - 1)
  i = i - 1
  For Each c In aRange
    i = i + 1
    a(i) = c
  Next c
  RangeTo1dArray = a()
End Function
 

Attachments

  • Attendance & Leave - Ken.xlsm
    424.9 KB · Views: 15
You must log in or register to reply here.
Back
Top