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:

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Count[/TD]
[TD]Labels[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Row labels[/TD]
[TD]7/3/2017[/TD]
[TD]7/4/2017[/TD]
[TD]7/5/2017[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]AAA[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]BBB[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]CCC[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]DDD[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]EEE[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]FFF[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]GGG[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]HHH[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]III[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Grand Total[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[Emeric]

Thank you. =)

I just had to make a small modification :
strFrm = Replace(strFrm, "@2", Cells(x + 2, UBound(arr, 2)).Address(0, 0))
Instead of:
strFrm = Replace(strFrm, "@2", Cells(x + 2, UBound(arr, 2) - 1).Address(0, 0))

I would like to make a modification on this line:
arr = .Cells(3, 2).Resize(11, 31).Value
by something like:
arr = .Cells(3, 2).Resize(11, Columns.count).Value
I want it more dynamic, because the number of date can vary. Which means that sometimes the table can stop on column "X" or goes to column "AF"...
I promise this this my last question... =/

 

[JackDanIce]

Untested, guess at making columns dynamic, 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")
        y = .Cells(3, .Columns.Count).End(xlToLeft).column
        arr = .Cells(3, 2).Resize(11, y).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)).Address(0, 0))
            arr(x, UBound(arr, 2)) = strFrm
        Next x
        Application.ScreenUpdating = False
        .Cells(3, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Application.ScreenUpdating = True
    End With
    
    Erase arr
    Set dic = Nothing

End Sub

 

[Emeric]

A big THANK YOU for your help !
You are the best, god like.

 

[JackDanIce]

You're welcome, glad it's finally resolved!

 

[Emeric]

Hello JackDanIce.

I would like to make a small modification to the code. I want to make the Column B more dynamic. Because if I have more than 9 values, it doesn't take them into consideration.
I know that I have to modify this line:
arr = .Cells(3, 2).Resize(11, y).Value
Probably by changing "11" by a "Row.count". I really don't know how to modify it. Can you please help me ?

 

[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")
        y = .Cells(3, .Columns.Count).End(xlToLeft).column
        x = .Cells(.Rows.Count, 2).End(xlUp).row - 2
        arr = .Cells(3, 2).Resize(x, y).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)).Address(0, 0))
            arr(x, UBound(arr, 2)) = strFrm
        Next x
        Application.ScreenUpdating = False
        .Cells(3, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Application.ScreenUpdating = True
    End With
    
    Erase arr
    Set dic = Nothing

End Sub

 

[Emeric]

Hi Thank you for your fast answer.

But there is a problem.

With your new code, Excel know exactly where to do the SUM, but the table is now empty... So all the SUMs are equal to 0.

 

[Emeric]

I works perfectly.
Thank you so much.

 

[JackDanIce]

You're welcome.