Fill a table with 2 Loops

E

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

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
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
Click to expand...

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.
Click to expand...

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
You must log in or register to reply here.

Similar threads

N
  • Solved
Copy/paste a row from within a loop, before that loop moves on to next cell
Replies
5
Views
525
Joe4
Joe4
L
  • Question Question
Prevent Pagebreak from hidden columns and rows, combine visible columns to one page wide
Replies
1
Views
239
bobsan42
bobsan42
Guinaba
  • Solved
Looping across all tabs and deleting empty rows
Replies
6
Views
319
Alex Blakenburg
A
J
  • Question Question
VBA code to send an email if a certain IF Criteria is met that loops when the spreadsheet is open
Replies
1
Views
583
joeyc123
J
J
  • Question Question
Formatting error when switching from Mac to PC
Replies
6
Views
59
RoryA
RoryA

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

Share this page

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