Excel VBA If Then Loop conditions -


i've been struggling few days. appreciated!

it's difficult explain, i'll best.

what i'm trying count number of results each query has , categorize them based on result count.

for example if query_a has 1 exact result , query_z has 1 exact result total of 2 queries have 1 result.

i'm trying use loop if statements, i'm @ loss.

here example data , output hoping for: query_example_data_and_results.xlsx - not real spreadsheet thousands of rows of data , large file size.

the code below pull query count (removing query dupes), not give query result count.. have provide code attempts, know i'm not close... have removed failed attempts hoping i'm being clear enough steered in right direction.

sub query_count()  g_40 = 0  query = ""  application.statusbar = " ~~ ~~ query count ~~ running ~~ ~~ " & x  x = 2  until sheets(1).cells(x, 1) = ""      if sheets(1).cells(x, 9) = "yes"     if query <> sheets(1).cells(x, 1)         g_40 = g_40 + 1     end if     end if     query = sheets(1).cells(x, 1)  x = x + 1  loop  application.statusbar = "done running query count of " & x & " rows!"  g = 40 sheets(3).cells(g, 7) = g_40 'query_count:  end sub 

thank in advance!

based on example code job:

option explicit  sub getresults()     application.screenupdating = false      dim ws1 worksheet, ws2 worksheet, lr&         set ws1 = thisworkbook.sheets("example_query_data")         set ws2 = thisworkbook.sheets("example_results")         lr = ws1.range("a" & rows.count).end(xlup).row      dim arr() string, i&, j&, cnt&     dim varr() string     cnt = 0      redim arr(lr - 2)     = 2 lr         arr(i - 2) = cstr(ws1.range("a" & i).value) ' fill array     next     call removeduplicate(arr) 'remove duplicate     redim varr(0 ubound(arr), 0 1)     = lbound(arr) ubound(arr)         varr(i, 0) = arr(i)         varr(i, 1) = getcount(arr(i), ws1, j, lr)     next      call preptable(ws2)     call updatetable(ws2, ws1, varr, j, lr) ' update table      application.screenupdating = true end sub  function getcount(qname$, byref ws1 worksheet, byref i&, lr&)     dim count&     count = 0     = 2 lr         if (strcomp(cstr(ws1.range("a" & i).value), qname, vbtextcompare) = 0) , _               (strcomp(cstr(ws1.range("c" & i).value), "yes", vbtextcompare) = 0) count = count + 1     next     getcount = count ' return count end function  sub updatetable(byref ws worksheet, byref ws2, byref arr() string, byref i&, lr&)     dim tbliter&     tbliter = 2 12         = lbound(arr) ubound(arr)             if arr(i, 1) = tbliter - 1                 ws.range("b" & tbliter).value = ws.range("b" & tbliter).value + 1             end if         next     next tbliter     call elevenandmore(ws, ws2, arr, lr, i) end sub  sub preptable(ws worksheet)     ws.range("b2:b12").clearcontents end sub  sub elevenandmore(byref ws worksheet, byref ws2, byref arr() string, lr&, byref i)     dim cnt&, j&     cnt = 0     = lbound(arr) ubound(arr)      j = 1 lr         if strcomp(cstr(ws2.range("a" & j).value), arr(i, 0), vbtextcompare) = 0             cnt = cnt + 1         end if      next j      if cnt > 10 ws.range("b12").value = ws.range("b12").value + 1      cnt = 0     next end sub  sub removeduplicate(byref stringarray() string)     dim lowbound$, upbound&, a&, b&, cur&, temparray() string     if (not stringarray) = true exit sub ' empty?     lowbound = lbound(stringarray)     upbound = ubound(stringarray)     redim temparray(lowbound upbound)     cur = lowbound ' first item     temparray(cur) = stringarray(lowbound)     = lowbound + 1 upbound         b = lowbound cur             if lenb(temparray(b)) = lenb(stringarray(a))                 if instrb(1, stringarray(a), temparray(b), vbbinarycompare) = 1 exit             end if         next b         if b > cur cur = b: temparray(cur) = stringarray(a)     next     redim preserve temparray(lowbound cur) ' resize     stringarray = temparray ' copy end sub 

post-comment edit: change these three:

add +28 tbliter

sub updatetable(byref ws worksheet, byref ws2, byref arr() string, byref i&, lr&)     dim tbliter&     tbliter = 2 12         = lbound(arr) ubound(arr)             if arr(i, 1) = tbliter - 1                 ws.range("b" & tbliter + 28).value = ws.range("b" & tbliter + 28).value + 1             end if         next     next tbliter     call elevenandmore(ws, ws2, arr, lr, i) end sub 

simply change location b40

sub elevenandmore(byref ws worksheet, byref ws2, byref arr() string, lr&, byref i)     dim cnt&, j&     cnt = 0     = lbound(arr) ubound(arr)      j = 1 lr         if strcomp(cstr(ws2.range("a" & j).value), arr(i, 0), vbtextcompare) = 0             cnt = cnt + 1         end if      next j      if cnt > 10 ws.range("b40").value = ws.range("b40").value + 1      cnt = 0     next end sub 

and prep table change range

sub preptable(ws worksheet)     ws.range("b30:b40").clearcontents end sub 

and should do!


Comments

Popular posts from this blog

Why does Ruby on Rails generate add a blank line to the end of a file? -

keyboard - Smiles and long press feature in Android -

node.js - Bad Request - node js ajax post -