Search code examples
excelvba

Looping Over Columns and Rows Referencing 2 Sheets with Countif Excel VBA

Excel Layout

  • 3 sheets (Client, Cloud, Validation)
  • Client & Cloud are raw sources
  • Client Sheet
  • Cloud Sheet
  • What I want to see in Validation sheet after running macro

Steps in Macro

  1. Copy all of Client sheet data and paste into Validation sheet
  2. Copy all of Cloud sheet data and paste below in Validation sheet
  3. Remove duplicates in each column of Validation sheet
  4. Insert 5 columns in front of each column with headers (Client, Cloud, Match, Var)
  5. for each column Client in Validation sheet take count of header value found in Client sheet
  6. for each column Cloud in Validation sheet take count of header value found in Cloud sheet (currently not included in loop)
  7. for each column Match in Validation sheet see if Cloud column matches Client (currently not included in loop)
  8. for each column Var in Validation sheet take variance of Client and Cloud (currently not included in loop)

My issue is with the last looping section, and below I commented out how it would look if the looping was taken out


'Set variables
Dim wsSource1 As Worksheet
Dim wsSource2 As Worksheet
Dim wsTarget As Worksheet
Dim UsdCols As Long
Dim Cnt As Long
Dim lastcolTarget As Long
Dim lastrowTarget As Long
Dim lastcolSource1 As Long
Dim lastrowSource1 As Long
Dim lastcolSource2 As Long
Dim lastrowSource2 As Long
Dim j As Long
Dim k As Long
Dim i As Long


'Set variables for source and destination sheets
Set wsSource1 = Worksheets("Client")
Set wsSource2 = Worksheets("Cloud")
Set wsTarget = Worksheets("Validation")

'headers for inserted columns
Dim headers()
headers() = Array("Client", "Cloud", "Match", "Var")

'clear sheet first
wsTarget.Cells.Clear

'Copy data from the source and Paste in the destination
Call wsSource1.UsedRange.Copy(wsTarget.Cells(1, 1))
Call wsSource2.UsedRange.Copy(wsTarget.Range("A" & Rows.Count).End(xlUp).Offset(1, 0))

'Stop the screen from updating to reduce lag
Application.ScreenUpdating = False
wsTarget.Activate
'Main loop
    For i = 1 To 100
        'ActiveWorkbook.Sheets("Validation").Columns(i).RemoveDuplicates Columns:=1, Header:=xlNo
        wsTarget.Columns(i).RemoveDuplicates Columns:=1, Header:=xlNo
    Next
'Reset ScreenUpdating
    Application.ScreenUpdating = True

'removing duplicates from each column
    UsdCols = wsTarget.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    For Cnt = Int(UsdCols / 1) * 1 To 1 Step -1
        Columns(Cnt + 1).Resize(, 5).Insert
        Columns(Cnt + 1).Resize(1, UBound(headers) + 2) = headers
    Next Cnt
 
'removes NAs from first row
wsTarget.Cells.Replace "#N/A", "", xlWhole
    
    lastcolTarget = wsTarget.Cells(1, Columns.Count).End(xlToLeft).Column
    lastrowTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolSource1 = wsSource1.Cells(1, Columns.Count).End(xlToLeft).Column
    lastrowSource1 = wsSource1.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolSource2 = wsSource2.Cells(1, Columns.Count).End(xlToLeft).Column
    lastrowSource2 = wsSource2.Cells(Rows.Count, 1).End(xlUp).Row
    
'THIS IS MY PROBLEM AREA STEP 5
    For k = 1 To lastcolSource1
        For i = 2 To lastrowTarget
            For j = 1 To lastcolTarget
                iCount = WorksheetFunction.CountIfs(wsSource1.Range(wsSource1.Cells(2, k), wsSource1.Cells(lastrowSource1, k)), wsTarget.Cells(i, j))
                wsTarget.Cells(i, j + 1).Value = iCount
                j = j + 5
            Next j
        Next i
    Next k


' THIS IS HOW I WOULD CODE IT WITH LESS LOOPING    
'        For i = 2 To lastrowTarget
'                iCount = WorksheetFunction.CountIfs(wsSource1.Range(wsSource1.Cells(2, 1), wsSource1.Cells(lastrowSource1, 1)), wsTarget.Cells(i, 1))
'                wsTarget.Cells(i, 2).Value = iCount
'                iCount2 = WorksheetFunction.CountIfs(wsSource1.Range(wsSource1.Cells(2, 2), wsSource1.Cells(lastrowSource1, 2)), wsTarget.Cells(i, 7))
'                wsTarget.Cells(i, 8).Value = iCount2
'                iCount3 = WorksheetFunction.CountIfs(wsSource1.Range(wsSource1.Cells(2, 3), wsSource1.Cells(lastrowSource1, 3)), wsTarget.Cells(i, 13))
'                wsTarget.Cells(i, 14).Value = iCount3
'         Next i
'
' STEP 6
'        For i = 2 To lastrowTarget
'                iCount = WorksheetFunction.CountIfs(wsSource2.Range(wsSource2.Cells(2, 1), wsSource2.Cells(lastrowSource2, 1)), wsTarget.Cells(i, 1))
'                wsTarget.Cells(i, 3).Value = iCount
'                iCount2 = WorksheetFunction.CountIfs(wsSource2.Range(wsSource2.Cells(2, 2), wsSource2.Cells(lastrowSource2, 2)), wsTarget.Cells(i, 7))
'                wsTarget.Cells(i, 9).Value = iCount2
'                iCount3 = WorksheetFunction.CountIfs(wsSource2.Range(wsSource2.Cells(2, 3), wsSource2.Cells(lastrowSource2, 3)), wsTarget.Cells(i, 13))
'                wsTarget.Cells(i, 15).Value = iCount3
'        Next i
'STEP 7
'        For i = 2 To lastrowTarget
'                iCount = wsTarget.Cells(i, 2).Value = wsTarget.Cells(i, 3).Value
'                wsTarget.Cells(i, 4).Value = iCount
'                iCount2 = wsTarget.Cells(i, 8).Value = wsTarget.Cells(i, 9).Value
'                wsTarget.Cells(i, 10).Value = iCount2
'                iCount3 = wsTarget.Cells(i, 14).Value = wsTarget.Cells(i, 15).Value
'                wsTarget.Cells(i, 16).Value = iCount3
'        Next i
'Step 8
'        For i = 2 To lastrowTarget
'                iCount = wsTarget.Cells(i, 2).Value - wsTarget.Cells(i, 3).Value
'                wsTarget.Cells(i, 5).Value = iCount
'                iCount2 = wsTarget.Cells(i, 8).Value - wsTarget.Cells(i, 9).Value
'                wsTarget.Cells(i, 11).Value = iCount2
'                iCount3 = wsTarget.Cells(i, 14).Value - wsTarget.Cells(i, 15).Value
'                wsTarget.Cells(i, 17).Value = iCount3
'        Next i
    
End Sub
Solution
    • Use Dictionary object to consolidate data based on names in each column.
    • Note: If my assumption is correct, there appears to be an additional row for Header2 in your screenshot.

    Microsoft documentation:

    Range.CurrentRegion property (Excel)

    Dictionary object

    Option Explicit

Sub Demo()
    Dim oSht3 As Worksheet
    Dim i As Long, j As Long, iR As Long
    Dim arrData1, arrData2, aVal, arrRes
    Dim LastCol As Long, objDic As Object, sKey
    Const SHT1 = "Client"
    Const SHT2 = "Cloud"
    Const SHT3 = "Validation"
    arrData1 = Sheets(SHT1).Range("A1").CurrentRegion.Value
    arrData2 = Sheets(SHT2).Range("A1").CurrentRegion.Value
    ' Validate sht1 and sht2 have same amount of cols
    If UBound(arrData1, 2) <> UBound(arrData2, 2) Then
        MsgBox "Source data tables are invalid."
    Else
        ' Clear sht3
        Set oSht3 = Sheets(SHT3)
        oSht3.Cells.Clear
        Set objDic = CreateObject("scripting.dictionary")
        ' Loop through cols
        For j = LBound(arrData1, 2) To UBound(arrData1, 2)
            objDic.RemoveAll
            ' Loop through rows on sht1
            For i = LBound(arrData1) + 1 To UBound(arrData1)
                sKey = arrData1(i, j)
                If objDic.exists(sKey) Then
                    aVal = objDic(sKey)
                    aVal(0) = aVal(0) + 1
                    objDic(sKey) = aVal
                Else
                    objDic(sKey) = Array(1, 0)
                End If
            Next
            ' Loop through rows on sht2
            For i = LBound(arrData2) + 1 To UBound(arrData2)
                sKey = arrData2(i, j)
                If objDic.exists(sKey) Then
                    aVal = objDic(sKey)
                    aVal(1) = aVal(1) + 1
                    objDic(sKey) = aVal
                Else
                    objDic(sKey) = Array(0, 1)
                End If
            Next
            ReDim arrRes(1 To objDic.Count + 1, 1 To 5)
            ' Header row
            arrRes(1, 1) = arrData1(1, j)
            arrRes(1, 2) = SHT1
            arrRes(1, 3) = SHT2
            arrRes(1, 4) = "Match"
            arrRes(1, 5) = "Var"
            iR = 1
            ' Populate output table
            For Each sKey In objDic.Keys
                iR = iR + 1
                arrRes(iR, 1) = sKey
                aVal = objDic(sKey)
                arrRes(iR, 2) = aVal(0)
                arrRes(iR, 3) = aVal(1)
                arrRes(iR, 4) = (aVal(0) = aVal(1))
                arrRes(iR, 5) = aVal(0) - aVal(1)
            Next
            ' Write data to sheet
            LastCol = oSht3.Cells(1, oSht3.Columns.Count).End(xlToLeft).Column
            If Len(oSht3.Cells(1, LastCol)) > 0 Then LastCol = LastCol + 1
            oSht3.Cells(1, LastCol).Resize(iR, 5).Value = arrRes
        Next
    End If
End Sub