CODEWITHSUNDEEP
excelvba
Imran Al Rashid
Imran Al Rashid

Reputation: 116

Multi-conditional lookup (conditions both in rows and columns) using Excel VBA

I am a teacher. Let's say -

I have 3 students. Their IDs are: 100,125, and 116.

I take classes in 3 consecutive periods. Period 1, 2 and 3.

I take classes 5 days a week. 40 minutes per class.

I keep records of their attendance in an excel sheet named DATAsheet. The sheet looks like this:

A B C D
1 STUDENT ID DATE PERIOD MINUTES ATTENDED IN CLASS
2 studentID100 9/1/2020 1 4
3 studentID125 9/1/2020 1 39
4 studentID116 9/1/2020 1 26
5 studentID125 9/1/2020 2 16
6 studentID116 9/1/2020 2 2
7 studentID100 9/1/2020 3 22
8 studentID116 9/1/2020 3 16
9 studentID100 9/2/2020 1 9
10 studentID116 9/2/2020 1 24
11 studentID125 9/2/2020 1 35
12 studentID125 9/2/2020 2 17
13 studentID116 9/2/2020 2 13
14 studentID100 9/2/2020 2 36
15 studentID125 9/2/2020 3 13
16 studentID116 9/2/2020 3 1

Please note: in this sheet, student IDs don't follow any fixed order.

I want to convert this into a different table in a separate sheet called OUTPUTsheet. The data should look like this:

A B C D E F G
1 9/1/2020 9/1/2020 9/1/2020 9/2/2020 9/2/2020 9/2/2020
2 1 2 3 1 2 3
3 studentID100 4 NA 22 9 36 NA
4 studentID125 39 16 NA 35 17 13
5 studentID116 26 2 16 24 13 1

Here, student IDs are in column A. Dates are in row 1. Periods are in row 2. And rest of the data is duration (in minutes) each student attended class each period. Column A, Row 1 and Row 2 in OUTPUTsheet are pre-set manually.

The VBA code I used:

    Sub student_attendance_sheet()

    
    Dim Found As Range, Firstfound As String
    Dim rngSearch As Range
    Dim Criteria1 As Variant, Criteria2 As Variant
    
    Set rngSearch = Sheets("DATAsheet").Range("A:A")
    
    
    For i = 3 To 5
        For j = 2 To 7
    
            With Sheets("OUTPUTsheet")
            Criteria1 = .Cells(i, 1).Value
            Criteria2 = .Range(.Cells(1, j), .Cells(2, j)).Value
            End With
                
            Set Found = rngSearch.Find(What:=Criteria1, _
                                       LookIn:=xlValues, _
                                       LookAt:=xlWhole, _
                                       SearchOrder:=xlByRows, _
                                       SearchDirection:=xlNext, _
                                       MatchCase:=False)
                
            If Not Found Is Nothing Then
                
                Firstfound = Found.Address
            
                Do
                    If Found.EntireRow.Range("B1").Value = Criteria2(1, 1) And _
                       Found.EntireRow.Range("C1").Value = Criteria2(2, 1) Then Exit Do 'Match found
                    
                    Set Found = rngSearch.FindNext(After:=Found)
                    If Found.Address = Firstfound Then Set Found = Nothing
                    
                Loop Until Found Is Nothing
                
            End If
            
            If Not Found Is Nothing Then
                
        
                Sheets("OUTPUTsheet").Cells(i, j).Value = Found.Offset(, 3)
                
            Else
        
                Sheets("OUTPUTsheet").Cells(i, j).Value = ""
            End If
    
        Next j
    Next i
    
End Sub

The code works. But veeery slow. Plus, This code does not handles errors well. For example, there was a #N/A in C15 in DATAsheet, which gave an error "Type Mismatch".

My real data consists of 20,000 columns and 2,000 rows. Even a formula approach or pivot table approach would be way faster than this. For some reason, I want to use VBA. But I want it to be faster than the other two approaches.

Can you suggest any improvement to this code or any other alternative code which performs faster and handles errors? Maybe using arrays or something like that.

Upvotes: 0

Views: 248

Answers (1)

CDP1802
CDP1802

Reputation: 16392

Try

Option Explicit

Sub student_attendance_sheet()

    Const INPUT_SHT = "DATAsheet"
    Const OUTPUT_SHT = "OUTPUTsheet"

    Dim wb As Workbook, wsIn As Worksheet, wsOut As Worksheet
    Dim iLastRow As Long, iLastCol As Integer, r As Long, c As Integer
    Dim dictCol As Object, dictRow As Object, key As String, sId As String
    Dim t0 As Single: t0 = Timer
    Dim cel as range

    Set dictCol = CreateObject("Scripting.Dictionary")
    Set dictRow = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook
    Set wsIn = wb.Sheets(INPUT_SHT)
    Set wsOut = wb.Sheets(OUTPUT_SHT)

    ' profile output sheet
    iLastCol = wsOut.UsedRange.Columns.Count
    For c = 2 To iLastCol
       key = Format(wsOut.Cells(1, c), "YYYYMMDD") & Format(wsOut.Cells(2, c), "00")
       dictCol.Add key, c
    Next

    ' students
    iLastRow = wsOut.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 3 To iLastRow
        key = Trim(wsOut.Cells(r, "A"))
        dictRow.Add key, r
    Next

    ' clear output sheet
    wsOut.Range("B3").Resize(iLastRow - 2, iLastCol - 1).ClearContents

    ' scan input
    iLastRow = wsIn.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To iLastRow

        sId = Trim(wsIn.Cells(r, "A"))
        key = Format(wsIn.Cells(r, "B"), "YYYYMMDD") & Format(wsIn.Cells(r, "C"), "00")

        If Not dictRow.exists(sId) Then
            'MsgBox "ERROR - No output row for " & sId, vbCritical
            'Exit Sub
        ElseIf Not dictCol.exists(key) Then
            MsgBox "ERROR - No output col for " & key, vbCritical
            Exit Sub
        Else

            ' update mins
            Set cel = wsOut.Cells(dictRow(sId), dictCol(key))
            cel.Value = cel.Value + wsIn.Cells(r, "D")
        End If
    Next

    MsgBox iLastRow - 1 & " rows scanned in " & Format(Timer - t0, "0.0 secs"), vbInformation
    
End Sub

Upvotes: 1

Related Questions