Fill a table with 2 Loops

[Emeric]

Hello ! =)

I have 2 sheets: “Sheet1” and “ALERT”.
On ALERT, I have 2 column “A” and “B”. “A” contains dates and “B” contains variables (CCC, DDD…).
On Sheet1 I have a table with 2 entries :

• From B4 to B12, I have all the unique variables from “B” in ALERT
• From C3 to AF3, I have all the unique dates from “A” in ALERT

I want in my table to count how many times each variable matches with a specific date.

I tried to write the code, but I’m stuck with “For Each”, because it’s not possible to settle 2 For Each condition.

Public Sub AMCperSOEID()

Set SOEID = Range(Worksheets("Alert").Range("B2"), Worksheets("Alert").Range("B2").End(xlDown))
Set DATES = Range(Worksheets("Alert").Range("A2"), Worksheets("Alert").Range("A2").End(xlDown))

lr = Cells(Rows.Count, 2).End(xlUp).Row - 1
lr2 = Cells(Rows.Count, 3).End(xlToLeft).Column

For i = lr To 4 Step -1
For j = lr2 To 3 Step -1
For Each cell In SOEID
If cell.Value = Range("b" & i).Value Then
For Each cell In DATES
If cell.Value = Range("C" & j).Value Then
Range("c" & i) = WorksheetFunction.CountIfs(SOEID, Range("b" & i), DATES, Range("C" & j))
End If
End If
Next
Next
Next
Next

End Sub

Thank you for your consideration.
Emeric

The table I want to fill looks like that:

	Count	Labels
	Row labels	7/3/2017	7/4/2017	7/5/2017
	AAA
	BBB
	CCC
	DDD
	EEE
	FFF
	GGG
	HHH
	III
	Grand Total

<tbody>
</tbody>

 

[JackDanIce]

This assumes the last row in Sheets("Alert") is the same for both columns A and B, try:

Sub AMCperSOEID_v1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim dic     As Object
    Const DELIM As String = "|"
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    Sheets("Sheet1").Cells(4, 3).Resize(9, 30).ClearContents
        
    With Sheets("Alert")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(2, 1).Resize(x - 1, 3).Value
    End With

    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 3) = arr(x, 1) & DELIM & arr(x, 2)
        dic(arr(x, 3)) = 1 + --(dic.exists(arr(x, 3))) * -dic(arr(x, 3))
    Next x
    Erase arr
    
    With Sheets("Sheet1")
        arr = .Cells(3, 2).Resize(10, 31).Value
        For x = LBound(arr, 1) + 1 To UBound(arr, 1)
            For y = LBound(arr, 2) + 1 To UBound(arr, 2)
                arr(x, y) = dic(arr(1, y) & DELIM & arr(x, 1))
            Next y
        Next x
        .Cells(3, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    
    Erase arr
    Set dic = Nothing

End Sub

 

[Emeric]

JackDanIce, your are ASTOUNING !!!

It works perfectly, thank you so much !

 

[JackDanIce]

You're welcome, glad it helped. Small change to code:

Sub AMCperSOEID_v1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim dic     As Object
    Dim strFrm  As String
    Const DELIM As String = "|"
    
    Set dic = CreateObject("Scripting.Dictionary")
        
    With Sheets("Alert")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(2, 1).Resize(x - 1, 3).Value
    End With

    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 3) = arr(x, 1) & DELIM & arr(x, 2)
        dic(arr(x, 3)) = dic(arr(x, 3)) - dic.exists(arr(x, 3))
    Next x
    Erase arr
    
    With Sheets("Sheet1")
        .Cells(4, 3).Resize(9, 30).ClearContents
        arr = .Cells(3, 2).Resize(11, 32).Value
        For x = LBound(arr, 1) + 1 To UBound(arr, 1) - 1
            For y = LBound(arr, 2) + 1 To UBound(arr, 2)
                arr(x, y) = dic(arr(1, y) & DELIM & arr(x, 1))
            Next y
        Next x
        .Cells(3, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    
    Erase arr
    Set dic = Nothing

End Sub

 

[Emeric]

Thank you. What it is use for ?

One more question, I would like to have at the end of each column and row a SUM. (E.G a SUM for column C and for row 4, and so on). Could you please help me with this ?

Best regards

 

[JackDanIce]

It's using a dictionary to test if a value of date and variable (e.g. "09/08/2017|AAA") exists in the dictionary and if it does, increments the count of it and if it doesn't then creates a new key, adds to the dictionary and gives it a count value of 1.

Code adjusted to include the SUM for rows 4 to 12 across columns C to AF:

Sub AMCperSOEID_v1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim dic     As Object
    Dim strFrm  As String
    
    Set dic = CreateObject("Scripting.Dictionary")
        
    With Sheets("Alert")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(2, 1).Resize(x - 1, 3).Value
    End With

    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 3) = arr(x, 1) & arr(x, 2)
        dic(arr(x, 3)) = dic(arr(x, 3)) - dic.exists(arr(x, 3))
    Next x
    Erase arr
    
    With Sheets("Sheet1")
        .Cells(4, 3).Resize(9, 30).ClearContents
        arr = .Cells(3, 2).Resize(11, 32).Value
        For x = LBound(arr, 1) + 1 To UBound(arr, 1) - 1
            For y = LBound(arr, 2) + 1 To UBound(arr, 2) - 1
                arr(x, y) = dic(arr(1, y) & arr(x, 1))
                strFrm = Replace("=SUM(@1:@2)", "@1", Cells(LBound(arr, 1) + 3, y + 1).Address(0, 0))
                strFrm = Replace(strFrm, "@2", Cells(UBound(arr, 1) + 1, y + 1).Address(0, 0))
                arr(UBound(arr, 1), y) = strFrm
            Next y
        Next x
        .Cells(3, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    
    Erase arr
    Set dic = Nothing

End Sub

 

[Emeric]

Thank you again, it works.
Ok I understand.

If you have time, I have one last question: I need to add a column, at the top right of the table. in each cell of this table I need the SUM of each cell of the corresponding line.
For example in AF:4, I will get the sum of C:4 + B:4 + ... + AE:4. and the same until the top right bottom of the table.
Can you please do it ? (=

Thank you

 

[JackDanIce]

From C3 to AF3, I have all the unique dates from “A” in ALERT

vs

For example in AF:4, I will get the sum of C:4 + B:4 + ... + AE:4. and the same until the top right bottom of the table.

What column should the SUM of the rows go into, AE, AF or AG?

 

[Emeric]

Basicaly what I want is:

AF4 = SUM(C4 + B4 +... + AE4)
AF5 = SUM(C5 + B5 +... + AE5)
AF6 = SUM(C6 + B6 +... + AE6)
...
AF13 = SUM(C13 + B13 +... + AE13)

 

[JackDanIce]

Try:

Sub AMCperSOEID_v1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim dic     As Object
    Dim strFrm  As String
    
    Set dic = CreateObject("Scripting.Dictionary")
        
    With Sheets("Alert")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(2, 1).Resize(x - 1, 3).Value
    End With

    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 3) = arr(x, 1) & arr(x, 2)
        dic(arr(x, 3)) = dic(arr(x, 3)) - dic.exists(arr(x, 3))
    Next x
    Erase arr
    
    With Sheets("Sheet1")
        arr = .Cells(3, 2).Resize(11, 31).Value
        For x = LBound(arr, 1) + 1 To UBound(arr, 1)
            For y = LBound(arr, 2) + 1 To UBound(arr, 2) - 1
                arr(x, y) = dic(arr(1, y) & arr(x, 1))
                strFrm = Replace("=SUM(@1:@2)", "@1", Cells(LBound(arr, 1) + 3, y + 1).Address(0, 0))
                strFrm = Replace(strFrm, "@2", Cells(UBound(arr, 1) + 1, y + 1).Address(0, 0))
                arr(UBound(arr, 1), y) = strFrm
            Next y
            strFrm = Replace("=SUM(@1:@2)", "@1", Cells(x + 2, LBound(arr, 2) + 2).Address(0, 0))
            strFrm = Replace(strFrm, "@2", Cells(x + 2, UBound(arr, 2) - 1).Address(0, 0))
            arr(x, UBound(arr, 2)) = strFrm
        Next x
        .Cells(3, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    
    Erase arr
    Set dic = Nothing

End Sub