Vba to Find amounts that Add up

[Biz]

Dear All,

I tried macro below but it does not work. Can someone please help me?



Sheet1


<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Arial,Arial; FONT-SIZE: 10pt" border=1 cellSpacing=0 cellPadding=0><COLGROUP><COL style="WIDTH: 30px; FONT-WEIGHT: bold"><COL style="WIDTH: 105px"><COL style="WIDTH: 91px"></COLGROUP><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt; FONT-WEIGHT: bold"><TD></TD><TD>A</TD><TD>B</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">1</TD><TD style="TEXT-ALIGN: right">110,531.02</TD><TD style="TEXT-ALIGN: right">1,061,735.98</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">2</TD><TD style="TEXT-ALIGN: right">48,937.38</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">3</TD><TD style="TEXT-ALIGN: right">44,758.39</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">4</TD><TD style="TEXT-ALIGN: right">40,999.65</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">5</TD><TD style="TEXT-ALIGN: right">35,187.60</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">6</TD><TD style="TEXT-ALIGN: right">35,079.06</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">7</TD><TD style="TEXT-ALIGN: right">33,094.77</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">8</TD><TD style="TEXT-ALIGN: right">33,027.10</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">9</TD><TD style="TEXT-ALIGN: right">32,844.66</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">10</TD><TD style="TEXT-ALIGN: right">29,676.20</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">11</TD><TD style="TEXT-ALIGN: right">25,861.65</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">12</TD><TD style="TEXT-ALIGN: right">25,255.46</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">13</TD><TD style="TEXT-ALIGN: right">22,814.95</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">14</TD><TD style="TEXT-ALIGN: right">20,881.26</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">15</TD><TD style="TEXT-ALIGN: right">19,999.32</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">16</TD><TD style="TEXT-ALIGN: right">19,177.09</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">17</TD><TD style="TEXT-ALIGN: right">17,976.80</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">18</TD><TD style="TEXT-ALIGN: right">16,678.58</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">19</TD><TD style="TEXT-ALIGN: right">15,600.37</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">20</TD><TD style="TEXT-ALIGN: right">15,162.55</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">21</TD><TD style="TEXT-ALIGN: right">14,224.72</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">22</TD><TD style="TEXT-ALIGN: right">13,160.34</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">23</TD><TD style="TEXT-ALIGN: right">13,035.54</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">24</TD><TD style="TEXT-ALIGN: right">12,775.74</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">25</TD><TD style="TEXT-ALIGN: right">12,953.12</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">26</TD><TD style="TEXT-ALIGN: right">12,378.17</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">27</TD><TD style="TEXT-ALIGN: right">11,422.66</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">28</TD><TD style="TEXT-ALIGN: right">10,548.42</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">29</TD><TD style="TEXT-ALIGN: right">10,540.93</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">30</TD><TD style="TEXT-ALIGN: right">11,159.81</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">31</TD><TD style="TEXT-ALIGN: right">10,354.13</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">32</TD><TD style="TEXT-ALIGN: right">10,867.97</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">33</TD><TD style="TEXT-ALIGN: right">10,679.16</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">34</TD><TD style="TEXT-ALIGN: right">10,066.26</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">35</TD><TD style="TEXT-ALIGN: right">9,579.45</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">36</TD><TD style="TEXT-ALIGN: right">8,647.37</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">37</TD><TD style="TEXT-ALIGN: right">8,402.56</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">38</TD><TD style="TEXT-ALIGN: right">8,287.56</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">39</TD><TD style="TEXT-ALIGN: right">8,127.40</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">40</TD><TD style="TEXT-ALIGN: right">8,320.23</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">41</TD><TD style="TEXT-ALIGN: right">8,030.10</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">42</TD><TD style="TEXT-ALIGN: right">7,753.39</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">43</TD><TD style="TEXT-ALIGN: right">7,375.32</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">44</TD><TD style="TEXT-ALIGN: right">6,976.75</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">45</TD><TD style="TEXT-ALIGN: right">7,081.45</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">46</TD><TD style="TEXT-ALIGN: right">6,683.93</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">47</TD><TD style="TEXT-ALIGN: right">6,710.84</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">48</TD><TD style="TEXT-ALIGN: right">6,710.84</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">49</TD><TD style="TEXT-ALIGN: right">6,693.51</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">50</TD><TD style="TEXT-ALIGN: right">6,615.61</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">51</TD><TD style="TEXT-ALIGN: right">6,613.41</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">52</TD><TD style="TEXT-ALIGN: right">6,473.89</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">53</TD><TD style="TEXT-ALIGN: right">6,350.95</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">54</TD><TD style="TEXT-ALIGN: right">6,378.01</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">55</TD><TD style="TEXT-ALIGN: right">6,031.92</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">56</TD><TD style="TEXT-ALIGN: right">6,520.24</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">57</TD><TD style="TEXT-ALIGN: right">5,758.59</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">58</TD><TD style="TEXT-ALIGN: right">5,709.38</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">59</TD><TD style="TEXT-ALIGN: right">5,379.75</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">60</TD><TD style="TEXT-ALIGN: right">5,343.27</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">61</TD><TD style="TEXT-ALIGN: right">5,328.55</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">62</TD><TD style="TEXT-ALIGN: right">5,216.87</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">63</TD><TD style="TEXT-ALIGN: right">5,218.88</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">64</TD><TD style="TEXT-ALIGN: right">5,131.96</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">65</TD><TD style="TEXT-ALIGN: right">5,038.37</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">66</TD><TD style="TEXT-ALIGN: right">5,021.48</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">67</TD><TD style="TEXT-ALIGN: right">4,743.15</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">68</TD><TD style="TEXT-ALIGN: right">4,956.46</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">69</TD><TD style="TEXT-ALIGN: right">4,305.94</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">70</TD><TD style="TEXT-ALIGN: right">4,168.87</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">71</TD><TD style="TEXT-ALIGN: right">3,953.72</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">72</TD><TD style="TEXT-ALIGN: right">4,053.51</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">73</TD><TD style="TEXT-ALIGN: right">4,228.65</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">74</TD><TD style="TEXT-ALIGN: right">3,943.96</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">75</TD><TD style="TEXT-ALIGN: right">4,111.74</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">76</TD><TD style="TEXT-ALIGN: right">3,848.88</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">77</TD><TD style="TEXT-ALIGN: right">3,824.55</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">78</TD><TD style="TEXT-ALIGN: right">3,888.67</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">79</TD><TD style="TEXT-ALIGN: right">3,664.90</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">80</TD><TD style="TEXT-ALIGN: right">3,658.13</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">81</TD><TD style="TEXT-ALIGN: right">3,574.25</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">82</TD><TD style="TEXT-ALIGN: right">3,501.69</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">83</TD><TD style="TEXT-ALIGN: right">3,299.33</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">84</TD><TD style="TEXT-ALIGN: right">3,333.45</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">85</TD><TD style="TEXT-ALIGN: right">3,306.25</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">86</TD><TD style="TEXT-ALIGN: right">3,218.71</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">87</TD><TD style="TEXT-ALIGN: right">3,221.67</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">88</TD><TD style="TEXT-ALIGN: right">3,143.59</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">89</TD><TD style="TEXT-ALIGN: right">3,405.83</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">90</TD><TD style="TEXT-ALIGN: right">3,405.83</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">91</TD><TD style="TEXT-ALIGN: right">3,101.14</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">92</TD><TD style="TEXT-ALIGN: right">3,083.97</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">93</TD><TD style="TEXT-ALIGN: right">2,983.68</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">94</TD><TD style="TEXT-ALIGN: right">3,067.14</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">95</TD><TD style="TEXT-ALIGN: right">3,208.84</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">96</TD><TD style="TEXT-ALIGN: right">3,037.82</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">97</TD><TD style="TEXT-ALIGN: right">2,818.95</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">98</TD><TD style="TEXT-ALIGN: right">2,774.96</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">99</TD><TD style="TEXT-ALIGN: right">2,713.73</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">100</TD><TD style="TEXT-ALIGN: right">2,713.73</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">101</TD><TD style="TEXT-ALIGN: right">2,663.57</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">102</TD><TD style="TEXT-ALIGN: right">2,502.81</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">103</TD><TD style="TEXT-ALIGN: right">2,482.68</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">104</TD><TD style="TEXT-ALIGN: right">2,498.65</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">105</TD><TD style="TEXT-ALIGN: right">2,440.56</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">106</TD><TD style="TEXT-ALIGN: right">2,601.48</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">107</TD><TD style="TEXT-ALIGN: right">2,331.01</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">108</TD><TD style="TEXT-ALIGN: right">2,331.64</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">109</TD><TD style="TEXT-ALIGN: right">2,328.54</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">110</TD><TD style="TEXT-ALIGN: right">2,270.91</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">111</TD><TD style="TEXT-ALIGN: right">2,215.47</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">112</TD><TD style="TEXT-ALIGN: right">2,220.13</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">113</TD><TD style="TEXT-ALIGN: right">2,311.17</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">114</TD><TD style="TEXT-ALIGN: right">2,173.05</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">115</TD><TD style="TEXT-ALIGN: right">2,243.40</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">116</TD><TD style="TEXT-ALIGN: right">2,089.42</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">117</TD><TD style="TEXT-ALIGN: right">2,216.11</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">118</TD><TD style="TEXT-ALIGN: right">2,075.95</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">119</TD><TD style="TEXT-ALIGN: right">1,947.03</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">120</TD><TD style="TEXT-ALIGN: right">1,616.82</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">121</TD><TD style="TEXT-ALIGN: right">1,657.08</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">122</TD><TD style="TEXT-ALIGN: right">1,582.03</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">123</TD><TD style="TEXT-ALIGN: right">1,515.90</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">124</TD><TD style="TEXT-ALIGN: right">1,412.67</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">125</TD><TD style="TEXT-ALIGN: right">1,338.13</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">126</TD><TD style="TEXT-ALIGN: right">1,230.83</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">127</TD><TD style="TEXT-ALIGN: right">1,225.07</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">128</TD><TD style="TEXT-ALIGN: right">1,207.00</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">129</TD><TD style="TEXT-ALIGN: right">1,223.34</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">130</TD><TD style="TEXT-ALIGN: right">1,220.02</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">131</TD><TD style="TEXT-ALIGN: right">1,221.01</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">132</TD><TD style="TEXT-ALIGN: right">1,093.81</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">133</TD><TD style="TEXT-ALIGN: right">1,087.35</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">134</TD><TD style="TEXT-ALIGN: right">1,118.70</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">135</TD><TD style="TEXT-ALIGN: right">1,084.00</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">136</TD><TD style="TEXT-ALIGN: right">1,069.96</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">137</TD><TD style="TEXT-ALIGN: right">1,074.32</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">138</TD><TD style="TEXT-ALIGN: right">1,003.75</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">139</TD><TD style="TEXT-ALIGN: right">855.61</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">140</TD><TD style="TEXT-ALIGN: right">779.48</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">141</TD><TD style="TEXT-ALIGN: right">762.31</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">142</TD><TD style="TEXT-ALIGN: right">695.73</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">143</TD><TD style="TEXT-ALIGN: right">738.70</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">144</TD><TD style="TEXT-ALIGN: right">707.50</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">145</TD><TD style="TEXT-ALIGN: right">624.84</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">146</TD><TD style="TEXT-ALIGN: right">610.73</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">147</TD><TD style="TEXT-ALIGN: right">610.73</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">148</TD><TD style="TEXT-ALIGN: right">608.59</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">149</TD><TD style="TEXT-ALIGN: right">601.18</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">150</TD><TD style="TEXT-ALIGN: right">603.78</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">151</TD><TD style="TEXT-ALIGN: right">625.49</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">152</TD><TD style="TEXT-ALIGN: right">650.37</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">153</TD><TD style="TEXT-ALIGN: right">649.01</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">154</TD><TD style="TEXT-ALIGN: right">616.40</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">155</TD><TD style="TEXT-ALIGN: right">603.78</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">156</TD><TD style="TEXT-ALIGN: right">599.53</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">157</TD><TD style="TEXT-ALIGN: right">620.17</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">158</TD><TD style="TEXT-ALIGN: right">619.55</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">159</TD><TD style="TEXT-ALIGN: right">619.55</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">160</TD><TD style="TEXT-ALIGN: right">621.19</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">161</TD><TD style="TEXT-ALIGN: right">638.88</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">162</TD><TD style="TEXT-ALIGN: right">610.01</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">163</TD><TD style="TEXT-ALIGN: right">543.16</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">164</TD><TD style="TEXT-ALIGN: right">542.04</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">165</TD><TD style="TEXT-ALIGN: right">555.03</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">166</TD><TD style="TEXT-ALIGN: right">546.91</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">167</TD><TD style="TEXT-ALIGN: right">535.86</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">168</TD><TD style="TEXT-ALIGN: right">561.67</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">169</TD><TD style="TEXT-ALIGN: right">566.86</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">170</TD><TD style="TEXT-ALIGN: right">577.79</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">171</TD><TD style="TEXT-ALIGN: right">577.79</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">172</TD><TD style="TEXT-ALIGN: right">522.82</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">173</TD><TD style="TEXT-ALIGN: right">531.89</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">174</TD><TD style="TEXT-ALIGN: right">521.01</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">175</TD><TD style="TEXT-ALIGN: right">530.10</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">176</TD><TD style="TEXT-ALIGN: right">530.10</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">177</TD><TD style="TEXT-ALIGN: right">678.20</TD><TD></TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">178</TD><TD style="TEXT-ALIGN: right">155.30</TD><TD></TD></TR></TBODY></TABLE>

Option Explicit
'Begin VBA Code

' By Harlan Grove
Sub findsums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

Const TOL As Double = 0.000001 'modify as needed
Dim c As Variant

Dim j As Long, k As Long, n As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim v As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp

re.Global = True
re.IgnoreCase = True

On Error Resume Next

Set x = Application.InputBox( _
Prompt:="Enter range of values:", _
Title:="findsums", _
Default:="", _
Type:=8 _
)

If x Is Nothing Then
Err.Clear
Exit Sub
End If

y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If

On Error GoTo 0

Set dco = dc1
Set dcn = dc2

Call recsoln

For Each y In x.Value2
If VarType(y) = vbDouble Then
If Abs(t - y) < TOL Then
recsoln "+" & Format(y)

ElseIf dco.Exists(y) Then
dco(y) = dco(y) + 1

ElseIf y < t - TOL Then
dco.Add Key:=y, Item:=1

c = CDec(c + 1)
Application.StatusBar = "[1] " & Format(c)

End If

End If
Next y

n = dco.Count

ReDim v(1 To n, 1 To 3)

For k = 1 To n
v(k, 1) = dco.Keys(k - 1)
v(k, 2) = dco.Items(k - 1)
Next k

qsortd v, 1, n

For k = n To 1 Step -1
v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
If v(k, 3) > t Then dcn.Add Key:="+" & _
Format(v(k, 1)), Item:=v(k, 1)
Next k

On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

For k = 2 To n
dco.RemoveAll
swapo dco, dcn

For Each y In dco.Keys
p = False

For j = 1 To n
If v(j, 3) < t - dco(y) - TOL Then Exit For
x = v(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True
If p Then
re.Pattern = "\" & s & "(?=(\+|$))"
If re.Execute(y).Count < v(j, 2) Then
u = dco(y) + x
If Abs(t - u) < TOL Then
recsoln y & s
ElseIf u < t - TOL Then
dcn.Add Key:=y & s, Item:=u
c = CDec(c + 1)
Application.StatusBar = "[" & Format(k) & "] " & _
Format(c)
End If
End If
End If
Next j
Next y

If dcn.Count = 0 Then Exit For
Next k

If (recsoln() = 0) Then _
MsgBox Prompt:="all combinations exhausted", _
Title:="No Solution"

CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False

End Sub

Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste

Static r As Range
Dim ws As Worksheet

If s = "" And r Is Nothing Then
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
If ws Is Nothing Then
Err.Clear
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
r.Parent.Name = OUTPUTWSN
ws.Activate
Application.ScreenUpdating = False
Else
ws.Cells.Clear
Set r = ws.Range("A1")
End If
recsoln = 0
ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing
Else
r.Value = s
Set r = r.Offset(1, 0)
recsoln = r.Row - 1
End If
End Function

Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim j As Long, pvt As Long

If (lft >= rgt) Then Exit Sub
swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
pvt = lft
For j = lft + 1 To rgt
If v(j, 1) > v(lft, 1) Then
pvt = pvt + 1
swap2 v, pvt, j
End If
Next j

swap2 v, lft, pvt

qsortd v, lft, pvt - 1
qsortd v, pvt + 1, rgt
End Sub

Private Sub swap2(v As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim t As Variant, k As Long

For k = LBound(v, 2) To UBound(v, 2)
t = v(i, k)
v(i, k) = v(j, k)
v(j, k) = t
Next k
End Sub

Private Sub swapo(a As Object, b As Object)
Dim t As Object

Set t = a
Set a = b
Set b = t
End Sub
'---- end VBA code ----

Your help would be greatly appreciated.

Biz

 

[chirp]

did this work for you?

 

[Biz]

did this work for you?

Not sure what to change mate. Could you please help me?

Biz

 

[chirp]

okay forget those this is an "updated" sort of version.

Similar...just copy each block into a separate code module.

to use:

if you use 2007+ you can go to the ribbon-->developer-->macros-->getCombinations

else you can go to tools-->macros-->getCombinations

then select one contiguous range with your data when you are prompted.
then select a cell/enter the value you want things to sum to when prompted
then select the approximate time you want the macro to run for...this is just rough, and dont expect to be exact

this will output all solutions to a new sheet.


Main Code Module:

Option Explicit
Option Base 0

Sub getCombinations()

Dim v, v1
Dim dub As Double, sumGoal As Double, maxLoopNum As Double
Dim i As Long, rowCnt As Long
Dim ans As String

'for test funtion operation
Dim timSum() As Double
Dim tim As Double
Dim j As Long, trialName As String
Dim ws As Worksheet

'***********************CHECK THESE BEFORE RUNNING ***************************
Const numTrials As Long = 1
Const numSubTrials As Long = 1
Const printResult As Boolean = True
Const skipUI As Boolean = False

trialName = "Test combo finder"
ReDim timSum(1 To numTrials)
'***********************CHECK THESE BEFORE RUNNING ***************************


On Error GoTo exitFunc

If Not skipUI Then
    v = Application.InputBox("Enter data range:", "Get Data Range", , , , , , 8).Value2
    sumGoal = Application.InputBox("Input goal total:", "Goal Total", , , , , , 1)
    maxLoopNum = Application.InputBox("Input the estimated number of minutes you want to run the function for:", , , , , , 1) * 60000000
Else
    v = Selection.Value2
End If


For j = 1 To numTrials
    tim = microTimer
    For i = 1 To numSubTrials
        dub = 0
        'call function here!!!
        If skipUI Then
            v1 = getAllMatchComb(4556.92, v, 100, 7, False)
        Else
            If maxLoopNum = 0 Then
                ans = MsgBox("If you continue then this will run for" & Chr(13) _
                & "an indeterminate length of time.  Do you wish to proceed?", vbYesNo, "Continue?")
                If ans = vbNo Then Exit Sub
            End If
            v1 = getAllMatchComb(sumGoal, v, , , , maxLoopNum)
        End If
    Next
    timSum(j) = microTimer - tim
Next

'this doesnt print the array, just info about the total time
If printResult Then
    With WorksheetFunction
        Debug.Print Chr(13) & trialName & Chr(13) & "Total time: " & .Sum(timSum) & Chr(13) & "Average: " & .Average(timSum) & Chr(13) & "Max: " & .Max(timSum) _
                        & Chr(13) & "Min :" & .Min(timSum) & Chr(13) & "Number of loops: " & dub
        On Error Resume Next
        Debug.Print "Standard Deviation: " & .StDev(timSum) & Chr(13)
    End With
End If

'prints array to sheet
On Error GoTo exitFunc
If Not skipUI Then
    ReDim v(LBound(v1) To UBound(v1), 1 To 1)
    For i = LBound(v1) To UBound(v1)
        v(i, 1) = v1(i)
    Next
    
    Set ws = ThisWorkbook.Worksheets.Add
    With ws
        If getArraySize(v) > .Rows.Count Then
            MsgBox "More results than rows.  Some solutions omitted."
            .Range("a1").Resize(.Rows.Count) = v
        Else
            .Range("a1").Resize(getArraySize(v)) = v
        End If
    End With
End If

exitFunc:
End Sub

Actual Recursive Function:

Option Explicit
Option Base 0

'arrays
Private solutionArray() As Variant, rowArr() As Long, finalDataArray() As Double
Private doWhat() As Long

'longs, counters and index
Private numSolutions As Long, solutionCount As Long, uBoundSolution As Long, recNum As Long
Private maxRec As Long, arraySizeJump As Long, uBnd As Long, savedUbound As Long
'doubles used for holding running total
Private GoalTotal As Double, allowableDiff As Double, mLoops As Double, minVal As Double
Private loopCnt As Double

'some booleans used to set/test for constant parameters
Private exitRecursion As Boolean, retJustNdx As Boolean, doLoop As Boolean, changeBound As Boolean

'returns combinations that match the goalTot of an all positive data set
'the default allowable difference should remain set at some non-zero small number (not beyond double accuracy)
'if allowableDIff is set to exactly 0 there is a significant performance hit
'the maximum number of loops corresponds to roughly a full day if constant speed, but likely
'hit other constraints first (array size?)
Public Function getAllMatchComb(goalTot As Double, _
                                dataArray As Variant, _
                                Optional numSolution As Long = 0, _
                                Optional maxRecursion As Long = -1, _
                                Optional includeAll As Boolean = True, _
                                Optional maxLoops As Variant, _
                                Optional returnNumLoops As Variant, _
                                Optional returnJustIndex As Boolean = False, _
                                Optional onlyUniqueSolutions As Boolean = True, _
                                Optional allowableDifference As Double = 0.000000001, _
                                Optional resizeSolutionJump As Long = 5000) _
                                As Variant
                                
Dim arraySize As Long, i As Long, maxFirst As Long, minRecursion As Long, lBnd As Long
Dim funcTst As Boolean
Dim tstMatch As Variant, tArr As Variant
Dim tmpSUM As Double, ans As String

On Error GoTo exitFunc

'checks if dataarray is array just for fun (time spent here is not going to be significant)
If Not isArray(dataArray) Then GoTo exitFunc
'checks that redimension is >0
If resizeSolutionJump < 1 Then GoTo exitFunc
If allowableDifference = 0 Then
    ans = MsgBox("AllowableDifference should be set to a small number greater" & Chr(13) _
                & "0 such as 0.0000001 for optimal performance.  Continue?", vbYesNo, _
                "Continue?")
    If ans = vbNo Then Exit Function
ElseIf allowableDifference < 0 Then
    Exit Function 'cant have negative diff
End If

'sets the bounds of the final solution array
If numSolutions > 0 Then
    uBoundSolution = numSolutions
Else: uBoundSolution = 10000 'this term is arbitrary
End If
            
    
'//Sets inputs to module level variables
numSolutions = numSolution
GoalTotal = goalTot
arraySizeJump = resizeSolutionJump
allowableDiff = allowableDifference
retJustNdx = returnJustIndex

'gets maxloop number from input (default 100 billion---30 hours ish (think would slow down though))
If Not IsMissing(maxLoops) Then
    If isNumber(maxLoops) Then
        mLoops = maxLoops
    Else: GoTo exitFunc
    End If
Else
    mLoops = 100000000000#
End If

'this is a bit messy and confusing when calling...essentially you want to count loops either
'when you want to return the num loops, or exit after..
doLoop = Not IsMissing(returnNumLoops) Or Not IsMissing(maxLoops)


'//Return a one dimensioned Array
'ensure input is one dimension (not just one dim, but also any entries that are
'arrays are "straightened out", this is an easy (probably not fastest) way of converting
'variant arrays from ranges to simple one dim arrays, order here does not matter

'****always returns a 0 based array*****
tArr = getOneDimArray(dataArray, , , funcTst)
If Not funcTst Then GoTo exitFunc
'****here after assume array is 0 based****

'get bounds of input
lBnd = LBound(tArr) 'will be 0
uBnd = UBound(tArr)

'//Sort Array
'sorts the input array
Call QSortE(tArr, , funcTst)
If Not funcTst Then GoTo exitFunc

'//Checks a few parameters to see if valid input
If hasNegatives(tArr, funcTst) Then
    'exits here as a seperate method should be used with negatives
    'namely an ascending sort, and getting out of the entire recursion level
    'when exceeding the goal total
    GoTo exitFunc
ElseIf Not funcTst Then
    GoTo exitFunc
End If

'//removes any values greater than the goal total
With WorksheetFunction
    'gets the index of the last entry less then or equal to the search total
    'tarr is sorted ascending at this point
    On Error Resume Next
    tstMatch = .Match(goalTot, tArr, 1)
    On Error GoTo exitFunc
    
    'if no error then resize array to exclude values larger than the target
    If Err.Number = 0 Then
        uBnd = tstMatch - 1
        ReDim Preserve tArr(lBnd To uBnd)
    End If
    
    'if total sum of entries is less then total exit
    If .Sum(tArr) < goalTot Then GoTo exitFunc
    
    '//sets minimum value of data set
    'exits if goal total is less then smallest entry in list
    minVal = .Min(tArr)
    If goalTot < minVal Then GoTo exitFunc
End With

'//ReFormat array
'reverses array and removes blanks and 0's
tArr = revArrayN(delFromArraySmall(tArr, Array(0)), True)

'gets final array size
uBnd = UBound(tArr)
lBnd = LBound(tArr) 'shouldnt have changed but just in case
arraySize = getArraySize(tArr)

'//Check if array is in valid format
'exits if not enough elements
If arraySize < 3 Then GoTo exitFunc
'double checks left bound of data array is 0 (needs to be (for simplicity and speed))
If lBnd <> 0 Then GoTo exitFunc


'//Gets the minimum recursion level
Do While tmpSUM < goalTot And minRecursion <= uBnd
    tmpSUM = tmpSUM + tArr(minRecursion)
    minRecursion = minRecursion + 1
Loop

tmpSUM = 0

'//Gets max elements per solution, as well as the Max index of the first recursion level
'This iterates from the smallest to largest in the array, finding the maximum
'number of elements that could possibly make up a solution
Do While tmpSUM <= goalTot And i <= uBnd
    tmpSUM = tmpSUM + tArr(uBnd - i)
    i = i + 1
Loop

'scale i back to reflect true max valid recursion level
i = i - 1

If maxRecursion < 1 Then
    maxRec = i                      'relative to 1 base
    maxFirst = arraySize - i - 1    'relative to 0 base
ElseIf maxRecursion <= i Then
    i = 0
    'this gets the maximum point at which the n element set of contigious values falls
    'below the goal total
    Do While sumPart(tArr, i, i + maxRecursion - 1) >= goalTot
        If i + maxRecursion - 1 > uBnd Then Exit Do
        i = i + 1
    Loop
    
    maxRec = maxRecursion           'relative to 1 base
    maxFirst = i - 1                'relative to 0 base
Else: Exit Function    'this means no matches
End If

'//sets the dimensions of a few arrays used for results
'sets the bounds for the array to hold solutions 1 at a time
ReDim rowArr(1 To maxRec)
ReDim solutionArray(1 To uBoundSolution)
ReDim finalDataArray(lBnd To uBnd)
ReDim uBndArr(1 To maxRec)
ReDim doWhat(1 To maxRec)

'//this is a very important loop...dictates the behaviour of each recursion level
'this is not the fastest way to do it, but is the most intuitive
'populates doWhat array (boolean)

'1 = check, add, recurse
'2 = dont check, dont add, recurse
'3 = check, dont add, recurse
'4 = check, add

For i = 1 To maxRec
    If i < minRecursion Then
        doWhat(i) = 2
    ElseIf i < maxRec Then
        If includeAll Then
            doWhat(i) = 1
        Else
            doWhat(i) = 3
        End If
    Else
        doWhat(i) = 4
    End If
Next

'populates final array (double)
For i = lBnd To uBnd
    finalDataArray(i) = CDbl(tArr(i))
Next

'sets ubound to the initial value of maxFirst
'sets some other inital values
savedUbound = uBnd - 1
uBnd = maxFirst - 1
minVal = minVal - allowableDiff 'this will have some unwanted consequences ie if set to 0
changeBound = True

'**************************************************
'**************************************************
Call matchRecurse(lBnd, 0) 'call actual function
'**************************************************
'**************************************************

'redim or erase array
If solutionCount > 0 Then
    ReDim Preserve solutionArray(1 To solutionCount)
    
    'return solutions
    If Not retJustNdx Then
        If onlyUniqueSolutions Then solutionArray = getUniqueArrayA(solutionArray)
    End If
    
    'returns solutions
    getAllMatchComb = solutionArray
Else
    'no solutions so exit
    Erase solutionArray
End If


exitFunc:
'sets returnnumloops to returned val...still want to know loops if no solutions/error
On Error Resume Next
returnNumLoops = loopCnt

'reset some module level variables
allowableDiff = 0: uBoundSolution = 0
solutionCount = 0: maxRec = 0
exitRecursion = False: mLoops = 0
recNum = 0: Erase solutionArray
Erase rowArr: uBnd = 0
minVal = 0: loopCnt = 0
End Function


Private Function matchRecurse(curInd As Long, _
                            curTotal As Double)

Dim testDub As Double, tempDub As Double
Dim i As Long, tmpDoWhat As Long

'increment the recursion number each call
recNum = recNum + 1
tempDub = GoalTotal - curTotal


'not sure how to do this faster
If changeBound Then
    If recNum <> 1 Then
        uBnd = savedUbound
        changeBound = False
    End If
End If

'this loopcnt method counts the number of times matchRecurse is called
'because it will take different times to evaluate different cases, it cannot be used exactly
'to moderate time, but limiting recursion calls is a fairly safe way of keeping time under control

'checks whether to keep track of loops
'these additional loop checks add considerable time, but are valuable
If doLoop Then
    loopCnt = loopCnt + 1
    
    If loopCnt > mLoops Then
        exitRecursion = True
        Exit Function
    End If
End If

'gets the "doWhat" for the current recNum
tmpDoWhat = doWhat(recNum)

'loop through from input to upperbound
For i = curInd To uBnd
    
    '1 = check, add, recurse
    '2 = dont check, dont add, recurse
    '3 = check, dont add, recurse
    '4 = check, add
    
        If tmpDoWhat < 2 Then
            'gets the difference between the running total and the goal total
            testDub = tempDub - finalDataArray(i)
            
            If testDub > allowableDiff Then
                If testDub < minVal Then GoTo skipChecks
                'adds to row array
                rowArr(recNum) = i + 1 'row arr keeps track from 1..up, whereas all else is 0 based
                'calls itself
                Call matchRecurse(i + 1, GoalTotal - testDub)
                'checks exit
                If exitRecursion Then Exit Function
            ElseIf testDub < -allowableDiff Then
                GoTo skipChecks
            Else
                'sets the row array to the current row
                rowArr(recNum) = i + 1
                
                'increments the solution count then adds to the solutionarray
                'if the solution count exceeds the array size than the array is redimensioned
                'this is expensive so arraySizeJump is good to be large
                solutionCount = solutionCount + 1
                
                'checks to redim
                If solutionCount > uBoundSolution Then
                    ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
                    uBoundSolution = uBoundSolution + arraySizeJump
                End If
                
                'checks which type of solution to store
                If Not retJustNdx Then
                    solutionArray(solutionCount) = getStrSol
                Else
                    solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
                End If
                
                'decides if exit
                If numSolutions <> solutionCount Then
                    GoTo skipChecks
                Else
                    exitRecursion = True
                    Exit Function
                End If
            End If
        ElseIf tmpDoWhat < 3 Then
            'adds to row array
            rowArr(recNum) = i + 1  'row arr keeps track from 1..up, whereas all else is 0 based
            'calls itself
            Call matchRecurse(i + 1, curTotal + finalDataArray(i))
            'checks exit
            If exitRecursion Then Exit Function
        ElseIf tmpDoWhat < 4 Then
            'gets the difference between the running total and the goal total
            testDub = tempDub - finalDataArray(i)
            
            If testDub > allowableDiff Then
                If testDub < minVal Then GoTo skipChecks
                'adds to row array
                rowArr(recNum) = i + 1  'row arr keeps track from 1..up, whereas all else is 0 based
                'calls itself
                Call matchRecurse(i + 1, GoalTotal - testDub)
                If exitRecursion Then Exit Function
            End If
        ElseIf Abs(tempDub - finalDataArray(i)) <= allowableDiff Then
            'sets the row array to the current row
            rowArr(recNum) = i + 1
            
            'increments the solution count then adds to the solutionarray
            'if the solution count exceeds the array size than the array is redimensioned
            'this is expensive so arraySizeJump is good to be large
            solutionCount = solutionCount + 1
        
            'checks to redim
            If solutionCount > uBoundSolution Then
                ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
                uBoundSolution = uBoundSolution + arraySizeJump
            End If
            
            If Not retJustNdx Then
                solutionArray(solutionCount) = getStrSol
            Else
                solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
            End If
                    
            'decides if exit
            If numSolutions <> solutionCount Then
                GoTo skipChecks
            Else
                exitRecursion = True
                Exit Function
            End If
        End If
skipChecks:
Next

'this just takes care of the true Ubound case
If tmpDoWhat <> 3 Then
    If Abs(tempDub - finalDataArray(i)) <= allowableDiff Then
        'sets the row array to the current row
        rowArr(recNum) = i + 1
        
        'increments the solution count then adds to the solutionarray
        'if the solution count exceeds the array size than the array is redimensioned
        'this is expensive so arraySizeJump is good to be large
        solutionCount = solutionCount + 1
    
        'checks to redim
        If solutionCount > uBoundSolution Then
            ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
            uBoundSolution = uBoundSolution + arraySizeJump
        End If
        
        If Not retJustNdx Then
            solutionArray(solutionCount) = getStrSol
        Else
            solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
        End If
                
        'decides if exit
        If numSolutions <> solutionCount Then
            GoTo exitIf
        Else
            exitRecursion = True
            Exit Function
        End If
    End If
End If

exitIf:
'delete entry in rowarr
rowArr(recNum) = 0

'decrement recursion number
recNum = recNum - 1

End Function


'no real error checking here...
Private Function getStrSol() As String
Dim tVar

For Each tVar In redimPreserveN(rowArr, 1, recNum)
    getStrSol = getStrSol & "+" & finalDataArray(tVar - 1)
Next
End Function

A number of functions:

Option Explicit
Option Base 0

'windows api call
                
Public Declare Function getFrequency Lib "kernel32" _
                    Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long

Public Declare Function getTickCount Lib "kernel32" _
                    Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long


'from msdn
Function microTimer() As Double
Dim cyTicks1 As Currency
Static cyFrequency As Currency

microTimer = 0
' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
    getTickCount cyTicks1
' Seconds
    If cyFrequency Then microTimer = cyTicks1 / cyFrequency
End Function

'returns a unique array from an array using dictionary
Public Function getUniqueArrayA(inputArray, _
                                Optional skipBlanks As Boolean = False, _
                                Optional matchCase As Boolean = True, _
                                Optional tst As Boolean) As Variant

Dim tDic As Object
Dim tArr As Variant, lastVal As Variant

tst = False
On Error GoTo exitFunc
'checks if input is array or range, exits if else
Select Case TypeName(inputArray)
    Case "Variant()"
    Case "Range"
        inputArray = inputArray
    Case Else
        Exit Function
End Select

'sets dictionary
Set tDic = CreateObject("scripting.dictionary")
If matchCase Then tDic.CompareMode = vbTextCompare

'loops through array
For Each tArr In inputArray
    'skips blanks if told
    If skipBlanks Then
        If tArr = vbNullString Then GoTo skipAdd
    End If
    
    'shortcut if sorted or partially sorted
    If tArr <> lastVal Then
        'adds unique to array
        tDic.Item(tArr) = Empty
        lastVal = tArr
    End If
skipAdd:
Next

'return array
getUniqueArrayA = tDic.Keys

tst = True
exitFunc:
Set tDic = Nothing
End Function

'lets you use redim preserve on one line
'no error check just exits
Public Function redimPreserveN(ByVal arr, lBnd As Long, uBnd As Long, _
                                Optional tst As Boolean) As Variant
tst = False
On Error GoTo exitFunc
ReDim Preserve arr(lBnd To uBnd)
redimPreserveN = arr
tst = True
exitFunc:
End Function

'checks if an array has any negative values

Public Function hasNegatives(arr, Optional tst As Boolean) As Boolean
Dim tVar As Variant

tst = False
On Error GoTo exitFunc
If Not isArray(arr) Then Exit Function

For Each tVar In arr
    If tVar < 0 Then
        tst = True
        hasNegatives = True
        Exit Function
    End If
Next

tst = True
exitFunc:
End Function

'simple takes an array and reverses it, copys, requires array mem*2
Public Function revArrayN(arr, _
                        Optional skipBlanks As Boolean = False, _
                        Optional tst As Boolean) As Variant()
Dim tVar, tArr
Dim i As Long

tst = False
On Error GoTo exitFunc

If Not isArray(arr) Then Exit Function

i = UBound(arr)
ReDim tArr(LBound(arr) To i)

For Each tVar In arr
    If skipBlanks Then If tVar = vbNullString Then GoTo nxt
    tArr(i) = tVar
    i = i - 1
nxt:
Next

revArrayN = tArr
tst = True
exitFunc:
End Function

Public Function getArraySize(testArray, _
                            Optional testDim As Long = 1, _
                            Optional tst As Boolean) As Long
tst = False
On Error GoTo exitFunc
    getArraySize = UBound(testArray, testDim) - LBound(testArray, testDim) + 1
    tst = True
exitFunc:
End Function

'sums part of an array
'does not have good error checking
Public Function sumPart(arr, ind1 As Long, ind2 As Long, _
                        Optional tst As Boolean) As Double
                        
Dim i As Long
Dim mn As Double, mx As Double

If Not isArray(arr) Then Exit Function
If mn < LBound(arr) Then Exit Function
If mx > UBound(arr) Then Exit Function

mn = rMin(ind1, ind2)
mx = rMax(ind1, ind2)

On Error Resume Next
For i = mn To mx
    If isNumber(arr(i)) Then sumPart = sumPart + arr(i)
Next

tst = Err.Number = 0

End Function

'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,6,4,2
Public Function rMax(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean

On Error Resume Next
For Each tVar In testNums
    If Not isNumber(tVar) Then GoTo nxt
    If notFirst Then
        If tVar > rMax Then rMax = tVar
    Else
        rMax = tVar
        notFirst = True
    End If
nxt:
Next

End Function

'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,6,4,2
Public Function rMin(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean

On Error Resume Next
For Each tVar In testNums
    If Not isNumber(tVar) Then GoTo nxt
    If notFirst Then
        If tVar < rMin Then rMin = tVar
    Else
        rMin = tVar
        notFirst = True
    End If
nxt:
Next

End Function

Public Function isNumber(testVar, _
                        Optional trueIfConvertable As Boolean = False) As Boolean

On Error GoTo exitFunc
Select Case VarType(testVar)
    Case 2 To 7, 14
        isNumber = True
    Case 8
        If trueIfConvertable Then
            If IsNumeric(testVar) Then isNumber = True
        End If
End Select

exitFunc:
End Function


Public Function isOneDim(testArray) As Boolean
Dim Result As Long
   On Error Resume Next
   Result = LBound(testArray, 2)
   isOneDim = Err.Number <> 0
End Function

'tests if array is initialized by tring to assign a value to its Ubnd
Public Function isArrayInitialized(testArray) As Boolean

Dim testLng As Long
   On Error Resume Next
   testLng = UBound(testArray)
   isArrayInitialized = Err.Number = 0
End Function


'returns a 0 dimensioned array
Public Function delFromArraySmall(arr, deleteThis, _
                            Optional matchCase As Boolean = True, _
                            Optional tst As Boolean) As Variant()

Dim tVar As Variant, tTst As Variant
Dim storeArr As Variant, cnt As Long
Dim isArr As Boolean


tst = False
On Error GoTo exitFunc

'ensures input is array
If isArray(deleteThis) Then isArr = True

'crestes an array to hold "non-deleted" items
ReDim storeArr(0 To UBound(arr) - LBound(arr))

'loops through skips over any matches...not best way of doing this
For Each tVar In arr
    If isArr Then
        For Each tTst In deleteThis
            If matchCase Then
                If tVar = tTst Then GoTo nxt
            ElseIf UCase(tVar) = UCase(tTst) Then GoTo nxt
            End If
        Next
    Else
        If matchCase Then
            If tVar = deleteThis Then GoTo nxt
        Else: If UCase(tVar) = UCase(tTst) Then GoTo nxt
        End If
    End If
    
    'makes it here than not in array...should really clean this function up
    storeArr(cnt) = tVar
    cnt = cnt + 1
nxt:
Next

ReDim Preserve storeArr(0 To cnt - 1)
delFromArraySmall = storeArr

tst = True
exitFunc:
End Function

Returns a one dimension array from a jagged/multi dimension array:

Option Explicit
Option Base 0

Private tempArray As Variant
Private incAdd As Long, uBnd As Long
Private cnt As Long

Public Function getOneDimArray(inputVar, _
                                Optional expectedSize As Long = 5000, _
                                Optional incrementalAdd As Long = 1000, _
                                Optional tst As Boolean _
                                ) As Variant()
Dim tmpArr As Variant

tst = False
On Error GoTo exitFunc
'set global variables to input
If expectedSize < 1 Then Exit Function
uBnd = expectedSize
If incrementalAdd < 1 Then Exit Function
incAdd = incrementalAdd

'redim temparray to the expected size (input)
ReDim tempArray(0 To uBnd)
cnt = 0: uBnd = 0

'actually call function
Call recurseOneDim(inputVar)

If cnt > 0 Then
    ReDim Preserve tempArray(0 To cnt - 1)
    getOneDimArray = tempArray
    tst = True
End If

exitFunc:
End Function


'simple recursive function to "straighten out" any variant array
'very slow should be used only in specific circumstances
'will not currently work with objects etc...easily adapted
Private Function recurseOneDim(testArray)

Dim tVal As Variant

On Error GoTo exitFunc

For Each tVal In testArray
    If Not isArray(tVal) Then
        If cnt > uBnd Then
            uBnd = uBnd + incAdd
            ReDim Preserve tempArray(0 To uBnd)
        End If
        
        tempArray(cnt) = tVal
        cnt = cnt + 1
    Else
        Call recurseOneDim(tVal)
    End If
Next

exitFunc:
End Function

Quick Sort:

Option Explicit
Option Base 0

Private arrayType As Long
Private compareMeth As VbCompareMethod


'simple qSort...picks the pivot at halfway point...
Private Function recurseSort(vArray As Variant, _
                            inLow As Long, _
                            inHi As Long)

Dim tmpLow As Long, tmpHi As Long
Dim tmpSwap As Variant, pivot As Variant

On Error GoTo exitFunc
tmpLow = inLow
tmpHi = inHi

pivot = vArray((inLow + inHi) \ 2)

Do While (tmpLow <= tmpHi)
    Select Case arrayType
        Case 2 To 7, 12, 14, 17
            Do
                If vArray(tmpLow) >= pivot Then Exit Do
                If tmpLow >= inHi Then Exit Do
                tmpLow = tmpLow + 1
            Loop
            
            Do
                If pivot >= vArray(tmpHi) Then Exit Do
                If tmpHi <= inLow Then Exit Do
                tmpHi = tmpHi - 1
            Loop
        Case 8
            Do
                If StrComp(vArray(tmpLow), pivot, compareMeth) <> -1 Then Exit Do
                If tmpLow >= inHi Then Exit Do
                tmpLow = tmpLow + 1
            Loop
            
            Do
                If StrComp(vArray(tmpLow), pivot, compareMeth) = -1 Then Exit Do
                If tmpHi <= inLow Then Exit Do
                tmpHi = tmpHi - 1
            Loop
        Case Else
            'other data types not supported
            Exit Function
    End Select


    If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
    End If
Loop

If (inLow < tmpHi) Then recurseSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then recurseSort vArray, tmpLow, inHi

exitFunc:
End Function



Public Function QSortE(vArray As Variant, _
                        Optional strCompareMode As VbCompareMethod = vbBinaryCompare, _
                        Optional tst As Boolean)

tst = False
On Error GoTo exitFunc
If Not isArray(vArray) Then Exit Function
arrayType = VarType(vArray) - 8192
compareMeth = strCompareMode
Call recurseSort(vArray, LBound(vArray), UBound(vArray))

tst = True

exitFunc:
arrayType = 0
End Function


'simple qSort...picks the pivot at halfway point...

Public Function QSortN(ByVal vArray As Variant, _
                        Optional strCompareMode As VbCompareMethod = vbBinaryCompare, _
                        Optional tst As Boolean) As Variant

tst = False
On Error GoTo exitFunc
If Not isArray(vArray) Then Exit Function
arrayType = VarType(vArray) - 8192
compareMeth = strCompareMode
Call recurseSort(vArray, LBound(vArray), UBound(vArray))
QSortN = vArray
tst = True

exitFunc:
arrayType = 0
End Function

 

[Biz]

okay forget those this is an "updated" sort of version.

Similar...just copy each block into a separate code module.

to use:

if you use 2007+ you can go to the ribbon-->developer-->macros-->getCombinations

else you can go to tools-->macros-->getCombinations

then select one contiguous range with your data when you are prompted.
then select a cell/enter the value you want things to sum to when prompted
then select the approximate time you want the macro to run for...this is just rough, and dont expect to be exact

this will output all solutions to a new sheet.


Main Code Module:

Option Explicit
Option Base 0
 
Sub getCombinations()
 
Dim v, v1
Dim dub As Double, sumGoal As Double, maxLoopNum As Double
Dim i As Long, rowCnt As Long
Dim ans As String
 
'for test funtion operation
Dim timSum() As Double
Dim tim As Double
Dim j As Long, trialName As String
Dim ws As Worksheet
 
'***********************CHECK THESE BEFORE RUNNING ***************************
Const numTrials As Long = 1
Const numSubTrials As Long = 1
Const printResult As Boolean = True
Const skipUI As Boolean = False
 
trialName = "Test combo finder"
ReDim timSum(1 To numTrials)
'***********************CHECK THESE BEFORE RUNNING ***************************
 
 
On Error GoTo exitFunc
 
If Not skipUI Then
    v = Application.InputBox("Enter data range:", "Get Data Range", , , , , , 8).Value2
    sumGoal = Application.InputBox("Input goal total:", "Goal Total", , , , , , 1)
    maxLoopNum = Application.InputBox("Input the estimated number of minutes you want to run the function for:", , , , , , 1) * 60000000
Else
    v = Selection.Value2
End If
 
 
For j = 1 To numTrials
    tim = microTimer
    For i = 1 To numSubTrials
        dub = 0
        'call function here!!!
        If skipUI Then
            v1 = getAllMatchComb(4556.92, v, 100, 7, False)
        Else
            If maxLoopNum = 0 Then
                ans = MsgBox("If you continue then this will run for" & Chr(13) _
                & "an indeterminate length of time.  Do you wish to proceed?", vbYesNo, "Continue?")
                If ans = vbNo Then Exit Sub
            End If
            v1 = getAllMatchComb(sumGoal, v, , , , maxLoopNum)
        End If
    Next
    timSum(j) = microTimer - tim
Next
 
'this doesnt print the array, just info about the total time
If printResult Then
    With WorksheetFunction
        Debug.Print Chr(13) & trialName & Chr(13) & "Total time: " & .Sum(timSum) & Chr(13) & "Average: " & .Average(timSum) & Chr(13) & "Max: " & .Max(timSum) _
                        & Chr(13) & "Min :" & .Min(timSum) & Chr(13) & "Number of loops: " & dub
        On Error Resume Next
        Debug.Print "Standard Deviation: " & .StDev(timSum) & Chr(13)
    End With
End If
 
'prints array to sheet
On Error GoTo exitFunc
If Not skipUI Then
    ReDim v(LBound(v1) To UBound(v1), 1 To 1)
    For i = LBound(v1) To UBound(v1)
        v(i, 1) = v1(i)
    Next
 
    Set ws = ThisWorkbook.Worksheets.Add
    With ws
        If getArraySize(v) > .Rows.Count Then
            MsgBox "More results than rows.  Some solutions omitted."
            .Range("a1").Resize(.Rows.Count) = v
        Else
            .Range("a1").Resize(getArraySize(v)) = v
        End If
    End With
End If
 
exitFunc:
End Sub

Actual Recursive Function:

Option Explicit
Option Base 0
 
'arrays
Private solutionArray() As Variant, rowArr() As Long, finalDataArray() As Double
Private doWhat() As Long
 
'longs, counters and index
Private numSolutions As Long, solutionCount As Long, uBoundSolution As Long, recNum As Long
Private maxRec As Long, arraySizeJump As Long, uBnd As Long, savedUbound As Long
'doubles used for holding running total
Private GoalTotal As Double, allowableDiff As Double, mLoops As Double, minVal As Double
Private loopCnt As Double
 
'some booleans used to set/test for constant parameters
Private exitRecursion As Boolean, retJustNdx As Boolean, doLoop As Boolean, changeBound As Boolean
 
'returns combinations that match the goalTot of an all positive data set
'the default allowable difference should remain set at some non-zero small number (not beyond double accuracy)
'if allowableDIff is set to exactly 0 there is a significant performance hit
'the maximum number of loops corresponds to roughly a full day if constant speed, but likely
'hit other constraints first (array size?)
Public Function getAllMatchComb(goalTot As Double, _
                                dataArray As Variant, _
                                Optional numSolution As Long = 0, _
                                Optional maxRecursion As Long = -1, _
                                Optional includeAll As Boolean = True, _
                                Optional maxLoops As Variant, _
                                Optional returnNumLoops As Variant, _
                                Optional returnJustIndex As Boolean = False, _
                                Optional onlyUniqueSolutions As Boolean = True, _
                                Optional allowableDifference As Double = 0.000000001, _
                                Optional resizeSolutionJump As Long = 5000) _
                                As Variant
 
Dim arraySize As Long, i As Long, maxFirst As Long, minRecursion As Long, lBnd As Long
Dim funcTst As Boolean
Dim tstMatch As Variant, tArr As Variant
Dim tmpSUM As Double, ans As String
 
On Error GoTo exitFunc
 
'checks if dataarray is array just for fun (time spent here is not going to be significant)
If Not isArray(dataArray) Then GoTo exitFunc
'checks that redimension is >0
If resizeSolutionJump < 1 Then GoTo exitFunc
If allowableDifference = 0 Then
    ans = MsgBox("AllowableDifference should be set to a small number greater" & Chr(13) _
                & "0 such as 0.0000001 for optimal performance.  Continue?", vbYesNo, _
                "Continue?")
    If ans = vbNo Then Exit Function
ElseIf allowableDifference < 0 Then
    Exit Function 'cant have negative diff
End If
 
'sets the bounds of the final solution array
If numSolutions > 0 Then
    uBoundSolution = numSolutions
Else: uBoundSolution = 10000 'this term is arbitrary
End If
 
 
'//Sets inputs to module level variables
numSolutions = numSolution
GoalTotal = goalTot
arraySizeJump = resizeSolutionJump
allowableDiff = allowableDifference
retJustNdx = returnJustIndex
 
'gets maxloop number from input (default 100 billion---30 hours ish (think would slow down though))
If Not IsMissing(maxLoops) Then
    If isNumber(maxLoops) Then
        mLoops = maxLoops
    Else: GoTo exitFunc
    End If
Else
    mLoops = 100000000000#
End If
 
'this is a bit messy and confusing when calling...essentially you want to count loops either
'when you want to return the num loops, or exit after..
doLoop = Not IsMissing(returnNumLoops) Or Not IsMissing(maxLoops)
 
 
'//Return a one dimensioned Array
'ensure input is one dimension (not just one dim, but also any entries that are
'arrays are "straightened out", this is an easy (probably not fastest) way of converting
'variant arrays from ranges to simple one dim arrays, order here does not matter
 
'****always returns a 0 based array*****
tArr = getOneDimArray(dataArray, , , funcTst)
If Not funcTst Then GoTo exitFunc
'****here after assume array is 0 based****
 
'get bounds of input
lBnd = LBound(tArr) 'will be 0
uBnd = UBound(tArr)
 
'//Sort Array
'sorts the input array
Call QSortE(tArr, , funcTst)
If Not funcTst Then GoTo exitFunc
 
'//Checks a few parameters to see if valid input
If hasNegatives(tArr, funcTst) Then
    'exits here as a seperate method should be used with negatives
    'namely an ascending sort, and getting out of the entire recursion level
    'when exceeding the goal total
    GoTo exitFunc
ElseIf Not funcTst Then
    GoTo exitFunc
End If
 
'//removes any values greater than the goal total
With WorksheetFunction
    'gets the index of the last entry less then or equal to the search total
    'tarr is sorted ascending at this point
    On Error Resume Next
    tstMatch = .Match(goalTot, tArr, 1)
    On Error GoTo exitFunc
 
    'if no error then resize array to exclude values larger than the target
    If Err.Number = 0 Then
        uBnd = tstMatch - 1
        ReDim Preserve tArr(lBnd To uBnd)
    End If
 
    'if total sum of entries is less then total exit
    If .Sum(tArr) < goalTot Then GoTo exitFunc
 
    '//sets minimum value of data set
    'exits if goal total is less then smallest entry in list
    minVal = .Min(tArr)
    If goalTot < minVal Then GoTo exitFunc
End With
 
'//ReFormat array
'reverses array and removes blanks and 0's
tArr = revArrayN(delFromArraySmall(tArr, Array(0)), True)
 
'gets final array size
uBnd = UBound(tArr)
lBnd = LBound(tArr) 'shouldnt have changed but just in case
arraySize = getArraySize(tArr)
 
'//Check if array is in valid format
'exits if not enough elements
If arraySize < 3 Then GoTo exitFunc
'double checks left bound of data array is 0 (needs to be (for simplicity and speed))
If lBnd <> 0 Then GoTo exitFunc
 
 
'//Gets the minimum recursion level
Do While tmpSUM < goalTot And minRecursion <= uBnd
    tmpSUM = tmpSUM + tArr(minRecursion)
    minRecursion = minRecursion + 1
Loop
 
tmpSUM = 0
 
'//Gets max elements per solution, as well as the Max index of the first recursion level
'This iterates from the smallest to largest in the array, finding the maximum
'number of elements that could possibly make up a solution
Do While tmpSUM <= goalTot And i <= uBnd
    tmpSUM = tmpSUM + tArr(uBnd - i)
    i = i + 1
Loop
 
'scale i back to reflect true max valid recursion level
i = i - 1
 
If maxRecursion < 1 Then
    maxRec = i                      'relative to 1 base
    maxFirst = arraySize - i - 1    'relative to 0 base
ElseIf maxRecursion <= i Then
    i = 0
    'this gets the maximum point at which the n element set of contigious values falls
    'below the goal total
    Do While sumPart(tArr, i, i + maxRecursion - 1) >= goalTot
        If i + maxRecursion - 1 > uBnd Then Exit Do
        i = i + 1
    Loop
 
    maxRec = maxRecursion           'relative to 1 base
    maxFirst = i - 1                'relative to 0 base
Else: Exit Function    'this means no matches
End If
 
'//sets the dimensions of a few arrays used for results
'sets the bounds for the array to hold solutions 1 at a time
ReDim rowArr(1 To maxRec)
ReDim solutionArray(1 To uBoundSolution)
ReDim finalDataArray(lBnd To uBnd)
ReDim uBndArr(1 To maxRec)
ReDim doWhat(1 To maxRec)
 
'//this is a very important loop...dictates the behaviour of each recursion level
'this is not the fastest way to do it, but is the most intuitive
'populates doWhat array (boolean)
 
'1 = check, add, recurse
'2 = dont check, dont add, recurse
'3 = check, dont add, recurse
'4 = check, add
 
For i = 1 To maxRec
    If i < minRecursion Then
        doWhat(i) = 2
    ElseIf i < maxRec Then
        If includeAll Then
            doWhat(i) = 1
        Else
            doWhat(i) = 3
        End If
    Else
        doWhat(i) = 4
    End If
Next
 
'populates final array (double)
For i = lBnd To uBnd
    finalDataArray(i) = CDbl(tArr(i))
Next
 
'sets ubound to the initial value of maxFirst
'sets some other inital values
savedUbound = uBnd - 1
uBnd = maxFirst - 1
minVal = minVal - allowableDiff 'this will have some unwanted consequences ie if set to 0
changeBound = True
 
'**************************************************
'**************************************************
Call matchRecurse(lBnd, 0) 'call actual function
'**************************************************
'**************************************************
 
'redim or erase array
If solutionCount > 0 Then
    ReDim Preserve solutionArray(1 To solutionCount)
 
    'return solutions
    If Not retJustNdx Then
        If onlyUniqueSolutions Then solutionArray = getUniqueArrayA(solutionArray)
    End If
 
    'returns solutions
    getAllMatchComb = solutionArray
Else
    'no solutions so exit
    Erase solutionArray
End If
 
 
exitFunc:
'sets returnnumloops to returned val...still want to know loops if no solutions/error
On Error Resume Next
returnNumLoops = loopCnt
 
'reset some module level variables
allowableDiff = 0: uBoundSolution = 0
solutionCount = 0: maxRec = 0
exitRecursion = False: mLoops = 0
recNum = 0: Erase solutionArray
Erase rowArr: uBnd = 0
minVal = 0: loopCnt = 0
End Function
 
 
Private Function matchRecurse(curInd As Long, _
                            curTotal As Double)
 
Dim testDub As Double, tempDub As Double
Dim i As Long, tmpDoWhat As Long
 
'increment the recursion number each call
recNum = recNum + 1
tempDub = GoalTotal - curTotal
 
 
'not sure how to do this faster
If changeBound Then
    If recNum <> 1 Then
        uBnd = savedUbound
        changeBound = False
    End If
End If
 
'this loopcnt method counts the number of times matchRecurse is called
'because it will take different times to evaluate different cases, it cannot be used exactly
'to moderate time, but limiting recursion calls is a fairly safe way of keeping time under control
 
'checks whether to keep track of loops
'these additional loop checks add considerable time, but are valuable
If doLoop Then
    loopCnt = loopCnt + 1
 
    If loopCnt > mLoops Then
        exitRecursion = True
        Exit Function
    End If
End If
 
'gets the "doWhat" for the current recNum
tmpDoWhat = doWhat(recNum)
 
'loop through from input to upperbound
For i = curInd To uBnd
 
    '1 = check, add, recurse
    '2 = dont check, dont add, recurse
    '3 = check, dont add, recurse
    '4 = check, add
 
        If tmpDoWhat < 2 Then
            'gets the difference between the running total and the goal total
            testDub = tempDub - finalDataArray(i)
 
            If testDub > allowableDiff Then
                If testDub < minVal Then GoTo skipChecks
                'adds to row array
                rowArr(recNum) = i + 1 'row arr keeps track from 1..up, whereas all else is 0 based
                'calls itself
                Call matchRecurse(i + 1, GoalTotal - testDub)
                'checks exit
                If exitRecursion Then Exit Function
            ElseIf testDub < -allowableDiff Then
                GoTo skipChecks
            Else
                'sets the row array to the current row
                rowArr(recNum) = i + 1
 
                'increments the solution count then adds to the solutionarray
                'if the solution count exceeds the array size than the array is redimensioned
                'this is expensive so arraySizeJump is good to be large
                solutionCount = solutionCount + 1
 
                'checks to redim
                If solutionCount > uBoundSolution Then
                    ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
                    uBoundSolution = uBoundSolution + arraySizeJump
                End If
 
                'checks which type of solution to store
                If Not retJustNdx Then
                    solutionArray(solutionCount) = getStrSol
                Else
                    solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
                End If
 
                'decides if exit
                If numSolutions <> solutionCount Then
                    GoTo skipChecks
                Else
                    exitRecursion = True
                    Exit Function
                End If
            End If
        ElseIf tmpDoWhat < 3 Then
            'adds to row array
            rowArr(recNum) = i + 1  'row arr keeps track from 1..up, whereas all else is 0 based
            'calls itself
            Call matchRecurse(i + 1, curTotal + finalDataArray(i))
            'checks exit
            If exitRecursion Then Exit Function
        ElseIf tmpDoWhat < 4 Then
            'gets the difference between the running total and the goal total
            testDub = tempDub - finalDataArray(i)
 
            If testDub > allowableDiff Then
                If testDub < minVal Then GoTo skipChecks
                'adds to row array
                rowArr(recNum) = i + 1  'row arr keeps track from 1..up, whereas all else is 0 based
                'calls itself
                Call matchRecurse(i + 1, GoalTotal - testDub)
                If exitRecursion Then Exit Function
            End If
        ElseIf Abs(tempDub - finalDataArray(i)) <= allowableDiff Then
            'sets the row array to the current row
            rowArr(recNum) = i + 1
 
            'increments the solution count then adds to the solutionarray
            'if the solution count exceeds the array size than the array is redimensioned
            'this is expensive so arraySizeJump is good to be large
            solutionCount = solutionCount + 1
 
            'checks to redim
            If solutionCount > uBoundSolution Then
                ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
                uBoundSolution = uBoundSolution + arraySizeJump
            End If
 
            If Not retJustNdx Then
                solutionArray(solutionCount) = getStrSol
            Else
                solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
            End If
 
            'decides if exit
            If numSolutions <> solutionCount Then
                GoTo skipChecks
            Else
                exitRecursion = True
                Exit Function
            End If
        End If
skipChecks:
Next
 
'this just takes care of the true Ubound case
If tmpDoWhat <> 3 Then
    If Abs(tempDub - finalDataArray(i)) <= allowableDiff Then
        'sets the row array to the current row
        rowArr(recNum) = i + 1
 
        'increments the solution count then adds to the solutionarray
        'if the solution count exceeds the array size than the array is redimensioned
        'this is expensive so arraySizeJump is good to be large
        solutionCount = solutionCount + 1
 
        'checks to redim
        If solutionCount > uBoundSolution Then
            ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
            uBoundSolution = uBoundSolution + arraySizeJump
        End If
 
        If Not retJustNdx Then
            solutionArray(solutionCount) = getStrSol
        Else
            solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
        End If
 
        'decides if exit
        If numSolutions <> solutionCount Then
            GoTo exitIf
        Else
            exitRecursion = True
            Exit Function
        End If
    End If
End If
 
exitIf:
'delete entry in rowarr
rowArr(recNum) = 0
 
'decrement recursion number
recNum = recNum - 1
 
End Function
 
 
'no real error checking here...
Private Function getStrSol() As String
Dim tVar
 
For Each tVar In redimPreserveN(rowArr, 1, recNum)
    getStrSol = getStrSol & "+" & finalDataArray(tVar - 1)
Next
End Function

A number of functions:

Option Explicit
Option Base 0
 
'windows api call
 
Public Declare Function getFrequency Lib "kernel32" _
                    Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
 
Public Declare Function getTickCount Lib "kernel32" _
                    Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
 
 
'from msdn
Function microTimer() As Double
Dim cyTicks1 As Currency
Static cyFrequency As Currency
 
microTimer = 0
' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
    getTickCount cyTicks1
' Seconds
    If cyFrequency Then microTimer = cyTicks1 / cyFrequency
End Function
 
'returns a unique array from an array using dictionary
Public Function getUniqueArrayA(inputArray, _
                                Optional skipBlanks As Boolean = False, _
                                Optional matchCase As Boolean = True, _
                                Optional tst As Boolean) As Variant
 
Dim tDic As Object
Dim tArr As Variant, lastVal As Variant
 
tst = False
On Error GoTo exitFunc
'checks if input is array or range, exits if else
Select Case TypeName(inputArray)
    Case "Variant()"
    Case "Range"
        inputArray = inputArray
    Case Else
        Exit Function
End Select
 
'sets dictionary
Set tDic = CreateObject("scripting.dictionary")
If matchCase Then tDic.CompareMode = vbTextCompare
 
'loops through array
For Each tArr In inputArray
    'skips blanks if told
    If skipBlanks Then
        If tArr = vbNullString Then GoTo skipAdd
    End If
 
    'shortcut if sorted or partially sorted
    If tArr <> lastVal Then
        'adds unique to array
        tDic.Item(tArr) = Empty
        lastVal = tArr
    End If
skipAdd:
Next
 
'return array
getUniqueArrayA = tDic.Keys
 
tst = True
exitFunc:
Set tDic = Nothing
End Function
 
'lets you use redim preserve on one line
'no error check just exits
Public Function redimPreserveN(ByVal arr, lBnd As Long, uBnd As Long, _
                                Optional tst As Boolean) As Variant
tst = False
On Error GoTo exitFunc
ReDim Preserve arr(lBnd To uBnd)
redimPreserveN = arr
tst = True
exitFunc:
End Function
 
'checks if an array has any negative values
 
Public Function hasNegatives(arr, Optional tst As Boolean) As Boolean
Dim tVar As Variant
 
tst = False
On Error GoTo exitFunc
If Not isArray(arr) Then Exit Function
 
For Each tVar In arr
    If tVar < 0 Then
        tst = True
        hasNegatives = True
        Exit Function
    End If
Next
 
tst = True
exitFunc:
End Function
 
'simple takes an array and reverses it, copys, requires array mem*2
Public Function revArrayN(arr, _
                        Optional skipBlanks As Boolean = False, _
                        Optional tst As Boolean) As Variant()
Dim tVar, tArr
Dim i As Long
 
tst = False
On Error GoTo exitFunc
 
If Not isArray(arr) Then Exit Function
 
i = UBound(arr)
ReDim tArr(LBound(arr) To i)
 
For Each tVar In arr
    If skipBlanks Then If tVar = vbNullString Then GoTo nxt
    tArr(i) = tVar
    i = i - 1
nxt:
Next
 
revArrayN = tArr
tst = True
exitFunc:
End Function
 
Public Function getArraySize(testArray, _
                            Optional testDim As Long = 1, _
                            Optional tst As Boolean) As Long
tst = False
On Error GoTo exitFunc
    getArraySize = UBound(testArray, testDim) - LBound(testArray, testDim) + 1
    tst = True
exitFunc:
End Function
 
'sums part of an array
'does not have good error checking
Public Function sumPart(arr, ind1 As Long, ind2 As Long, _
                        Optional tst As Boolean) As Double
 
Dim i As Long
Dim mn As Double, mx As Double
 
If Not isArray(arr) Then Exit Function
If mn < LBound(arr) Then Exit Function
If mx > UBound(arr) Then Exit Function
 
mn = rMin(ind1, ind2)
mx = rMax(ind1, ind2)
 
On Error Resume Next
For i = mn To mx
    If isNumber(arr(i)) Then sumPart = sumPart + arr(i)
Next
 
tst = Err.Number = 0
 
End Function
 
'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,6,4,2
Public Function rMax(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean
 
On Error Resume Next
For Each tVar In testNums
    If Not isNumber(tVar) Then GoTo nxt
    If notFirst Then
        If tVar > rMax Then rMax = tVar
    Else
        rMax = tVar
        notFirst = True
    End If
nxt:
Next
 
End Function
 
'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,6,4,2
Public Function rMin(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean
 
On Error Resume Next
For Each tVar In testNums
    If Not isNumber(tVar) Then GoTo nxt
    If notFirst Then
        If tVar < rMin Then rMin = tVar
    Else
        rMin = tVar
        notFirst = True
    End If
nxt:
Next
 
End Function
 
Public Function isNumber(testVar, _
                        Optional trueIfConvertable As Boolean = False) As Boolean
 
On Error GoTo exitFunc
Select Case VarType(testVar)
    Case 2 To 7, 14
        isNumber = True
    Case 8
        If trueIfConvertable Then
            If IsNumeric(testVar) Then isNumber = True
        End If
End Select
 
exitFunc:
End Function
 
 
Public Function isOneDim(testArray) As Boolean
Dim Result As Long
   On Error Resume Next
   Result = LBound(testArray, 2)
   isOneDim = Err.Number <> 0
End Function
 
'tests if array is initialized by tring to assign a value to its Ubnd
Public Function isArrayInitialized(testArray) As Boolean
 
Dim testLng As Long
   On Error Resume Next
   testLng = UBound(testArray)
   isArrayInitialized = Err.Number = 0
End Function
 
 
'returns a 0 dimensioned array
Public Function delFromArraySmall(arr, deleteThis, _
                            Optional matchCase As Boolean = True, _
                            Optional tst As Boolean) As Variant()
 
Dim tVar As Variant, tTst As Variant
Dim storeArr As Variant, cnt As Long
Dim isArr As Boolean
 
 
tst = False
On Error GoTo exitFunc
 
'ensures input is array
If isArray(deleteThis) Then isArr = True
 
'crestes an array to hold "non-deleted" items
ReDim storeArr(0 To UBound(arr) - LBound(arr))
 
'loops through skips over any matches...not best way of doing this
For Each tVar In arr
    If isArr Then
        For Each tTst In deleteThis
            If matchCase Then
                If tVar = tTst Then GoTo nxt
            ElseIf UCase(tVar) = UCase(tTst) Then GoTo nxt
            End If
        Next
    Else
        If matchCase Then
            If tVar = deleteThis Then GoTo nxt
        Else: If UCase(tVar) = UCase(tTst) Then GoTo nxt
        End If
    End If
 
    'makes it here than not in array...should really clean this function up
    storeArr(cnt) = tVar
    cnt = cnt + 1
nxt:
Next
 
ReDim Preserve storeArr(0 To cnt - 1)
delFromArraySmall = storeArr
 
tst = True
exitFunc:
End Function

Returns a one dimension array from a jagged/multi dimension array:

Option Explicit
Option Base 0
 
Private tempArray As Variant
Private incAdd As Long, uBnd As Long
Private cnt As Long
 
Public Function getOneDimArray(inputVar, _
                                Optional expectedSize As Long = 5000, _
                                Optional incrementalAdd As Long = 1000, _
                                Optional tst As Boolean _
                                ) As Variant()
Dim tmpArr As Variant
 
tst = False
On Error GoTo exitFunc
'set global variables to input
If expectedSize < 1 Then Exit Function
uBnd = expectedSize
If incrementalAdd < 1 Then Exit Function
incAdd = incrementalAdd
 
'redim temparray to the expected size (input)
ReDim tempArray(0 To uBnd)
cnt = 0: uBnd = 0
 
'actually call function
Call recurseOneDim(inputVar)
 
If cnt > 0 Then
    ReDim Preserve tempArray(0 To cnt - 1)
    getOneDimArray = tempArray
    tst = True
End If
 
exitFunc:
End Function
 
 
'simple recursive function to "straighten out" any variant array
'very slow should be used only in specific circumstances
'will not currently work with objects etc...easily adapted
Private Function recurseOneDim(testArray)
 
Dim tVal As Variant
 
On Error GoTo exitFunc
 
For Each tVal In testArray
    If Not isArray(tVal) Then
        If cnt > uBnd Then
            uBnd = uBnd + incAdd
            ReDim Preserve tempArray(0 To uBnd)
        End If
 
        tempArray(cnt) = tVal
        cnt = cnt + 1
    Else
        Call recurseOneDim(tVal)
    End If
Next
 
exitFunc:
End Function

Quick Sort:

Option Explicit
Option Base 0
 
Private arrayType As Long
Private compareMeth As VbCompareMethod
 
 
'simple qSort...picks the pivot at halfway point...
Private Function recurseSort(vArray As Variant, _
                            inLow As Long, _
                            inHi As Long)
 
Dim tmpLow As Long, tmpHi As Long
Dim tmpSwap As Variant, pivot As Variant
 
On Error GoTo exitFunc
tmpLow = inLow
tmpHi = inHi
 
pivot = vArray((inLow + inHi) \ 2)
 
Do While (tmpLow <= tmpHi)
    Select Case arrayType
        Case 2 To 7, 12, 14, 17
            Do
                If vArray(tmpLow) >= pivot Then Exit Do
                If tmpLow >= inHi Then Exit Do
                tmpLow = tmpLow + 1
            Loop
 
            Do
                If pivot >= vArray(tmpHi) Then Exit Do
                If tmpHi <= inLow Then Exit Do
                tmpHi = tmpHi - 1
            Loop
        Case 8
            Do
                If StrComp(vArray(tmpLow), pivot, compareMeth) <> -1 Then Exit Do
                If tmpLow >= inHi Then Exit Do
                tmpLow = tmpLow + 1
            Loop
 
            Do
                If StrComp(vArray(tmpLow), pivot, compareMeth) = -1 Then Exit Do
                If tmpHi <= inLow Then Exit Do
                tmpHi = tmpHi - 1
            Loop
        Case Else
            'other data types not supported
            Exit Function
    End Select
 
 
    If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
    End If
Loop
 
If (inLow < tmpHi) Then recurseSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then recurseSort vArray, tmpLow, inHi
 
exitFunc:
End Function
 
 
 
Public Function QSortE(vArray As Variant, _
                        Optional strCompareMode As VbCompareMethod = vbBinaryCompare, _
                        Optional tst As Boolean)
 
tst = False
On Error GoTo exitFunc
If Not isArray(vArray) Then Exit Function
arrayType = VarType(vArray) - 8192
compareMeth = strCompareMode
Call recurseSort(vArray, LBound(vArray), UBound(vArray))
 
tst = True
 
exitFunc:
arrayType = 0
End Function
 
 
'simple qSort...picks the pivot at halfway point...
 
Public Function QSortN(ByVal vArray As Variant, _
                        Optional strCompareMode As VbCompareMethod = vbBinaryCompare, _
                        Optional tst As Boolean) As Variant
 
tst = False
On Error GoTo exitFunc
If Not isArray(vArray) Then Exit Function
arrayType = VarType(vArray) - 8192
compareMeth = strCompareMode
Call recurseSort(vArray, LBound(vArray), UBound(vArray))
QSortN = vArray
tst = True
 
exitFunc:
arrayType = 0
End Function

Mate

I get error message on
getOneDimArray

Sub or Function not defined.

Not sure how to fix it.

Biz

 

[chirp]

the code works as posted, you must not have copied correctly.

here is another solution that is slightly easier to set up (albeit slower).

alternate solution

 

[Biz]

the code works as posted, you must not have copied correctly.

here is another solution that is slightly easier to set up (albeit slower).

alternate solution

M8 you are right I forgot to copy one section. Nice work!

Biz

 

[Biz]

Quick question.

Can scripting display cell references too?

Biz

 

[chirp]

it COULD. the problem is that it sorts, reverses and then removes any totals greater than the goal total before generating solutions. there is built in functionality to get references to these positions, which could be easily converted to cell references, but it would all be a little tricky and a little slower.

i don't really want to do this, but if you want to experiment you can look at the function especially the "retJustNdx" which will return an array of arrays containing the index of the combination within a sorted, reversed array with all vals> goal total removed.