Fill a table with 2 Loops

Emeric

New Member
Joined
Jul 19, 2017
Messages
27
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]
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
This assumes the last row in Sheets("Alert") is the same for both columns A and B, try:
Code:
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
 
Last edited:
Upvote 0
You're welcome, glad it helped. Small change to code:
Rich (BB 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
 
Last edited:
Upvote 0
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
 
Upvote 0
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:
Code:
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
 
Last edited:
Upvote 0
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
 
Upvote 0
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?
 
Last edited:
Upvote 0
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)
 
Upvote 0
Try:
Code:
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
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top