在VBA中分组大小相同

我是VBA编程的新手，我有兴趣完成一个小小的项目，在纸上写成代码。

问题：给定一个26行（按字母顺序排列的AZ）数据集及其相应的logging数，根据计数将它们分成n组（n> 0），相当于每个字母对该组唯一。 所以如果第一组有A，B，C，那么其他组不能使用这个字母。

当我解决这一篇文章时，这是我的思考过程：

1. 将数据复制到页面的不同部分，以便我可以操纵数据。
2. 总计所有logging的总数（autosum A〜Z_count）
3. 根据总logging数，从最大到最小sorting数据
4. 查找每条logging总数的百分比（总数/次数）
5. 自私地distrubte数据，以便当组数据总和小于total_percent /数量的组开始检查每个字母，并将该数据保存到主数据侧excel表。

下面是我在c ++中的这个问题的伪代码，以及我手工使用和解决的数据。 就像我说的，我对VBA很新，所以我想创build一个macros来自动解决这个问题，如果我将来有另一个文档的话。

int totalcount = sum(letter_index) int index_percent = count/total int i = 1 int group_i_data_percent_sum = 0.0 int total_percent = 1 int n_groups = 5 //Can vary based on user desired input while (group_i_data_percent_sum =< total_percent/n_groups) { //Check to see if our value is less than total_ if((index_percent + group_i_data_percent_sum) < total_percent/n_groups) { //Add on the data group_i_data_percent_sum= current_letter_percent + group_i_data_percent_sum //Store a list of the accepted letters added together. } //Otherwise store the list into a data table and increment to next letter } //Repeat for all n_groups till all letters are uniquely added to groups. 

我为5人和6人的手写解决scheme。https://drive.google.com/file/d/0Bz2sgKh9NVmVUGlfZ1NETlJwaTg/view?usp=sharing

Answer 1

我想回答这个问题，因为这是一个很好的机会来解释一些VBA的function。 macros代码生成器在logging击键方面占有一席之地，但是这里的很多post都是自动生成的代码的简单粘贴，如下所示：“我如何循环这个？

确实，那些希望开发应用程序的人不会使用VBA，但这并不是说VBA是一种较小的语言。 VBA真是相当不错…只要开发人员摆脱击键logging，将脚趾浸入面向对象的编程领域。

开发人员1）从Excel中读取数据，2）完成所有数据处理，3）只有这样才将结果写回Excel。

下面的代码向您展示了VBA如何使用您所概述的任务来完成这一任务。 我不得不说，我不认为你的步骤是这个任务的最佳解决scheme，但是我会在这篇文章之外留下的。 我可以告诉你的不是如何将你的伪代码直接转换成VBA，而是如何使用一些VBA的对象来实现同样的事情。 顺便说一句，我不认为你的伪代码匹配你的手写解决scheme – 如果你采取组1，例如：'S'+'C'= 0.1683710而你的代码将不会接受任何总数超过0.1666667所以'S'和' C'不会以编程方式创build同一个组。

无论如何，在代码…

首先，添加两个Class Modules （插入 – >类模块）。 命名第一个cLetterFields并添加以下代码：

 Public Letter As String Public Frequency As Integer 

命名第二个类cAcceptedFields并添加以下代码：

 Public TotalFrequency As Integer Public MemberLetters As Collection 

在您的模块中，添加以下过程：

 Public Sub RunMe() Const BOOK_NAME As String = "My Book.xlsm" 'rename to your book Const SHEET_NAME As String = "Sheet1" 'rename to your sheet Const READ_ADDRESS As String = "A2:B27" 'amend as suits Const WRITE_ADDRESS As String = "D2" 'amend as suits Dim readArray As Variant Dim writeArray() As Variant Dim values As cLetterFields Dim accepted As cAcceptedFields Dim groupList As Collection Dim letterList As Collection Dim nGroups As Integer Dim totalFrq As Integer Dim maxGroupFrq As Integer Dim largestGroupSize As Integer Dim i As Integer Dim j As Integer Dim v As Variant ' Read the values from the worksheet readArray = Workbooks(BOOK_NAME). _ Worksheets(SHEET_NAME). _ Range(READ_ADDRESS).Value2 ' Sort the values readArray = QSort2D(readArray, 1, UBound(readArray, 1), 2, False) ' Populate the collection of letters and their frequencies ' by assigning values to the cLetterField class. Set letterList = New Collection For i = 1 To UBound(readArray, 1) Set values = New cLetterFields values.Letter = readArray(i, 1) values.Frequency = readArray(i, 2) letterList.Add values, Key:=values.Letter totalFrq = totalFrq + values.Frequency Next nGroups = 6 'amend the acquisition of this as you need. ' Populate the groups. largestGroupSize = 0 maxGroupFrq = Int(totalFrq / nGroups) Set groupList = New Collection For i = 1 To nGroups ' Initialise the group. Set accepted = New cAcceptedFields Set accepted.MemberLetters = New Collection accepted.TotalFrequency = 0 groupList.Add accepted ' Loop through the letters and add them to the group if they fit. For Each values In letterList If accepted.TotalFrequency + values.Frequency <= maxGroupFrq Or i = nGroups Then accepted.MemberLetters.Add values.Letter accepted.TotalFrequency = accepted.TotalFrequency + values.Frequency ' Remove the accepted letter from the list. letterList.Remove values.Letter ' Get the group size to dimension our write array. If accepted.MemberLetters.Count > largestGroupSize Then largestGroupSize = accepted.MemberLetters.Count End If End If Next Next ' Write the data to the worksheet. ReDim writeArray(1 To largestGroupSize + 2, 1 To nGroups + 1) writeArray(1, 1) = "Counsellor" writeArray(largestGroupSize + 2, 1) = "TOTAL" i = 0 For Each accepted In groupList i = i + 1 writeArray(1, 1 + i) = i j = 1 For Each v In accepted.MemberLetters j = j + 1 writeArray(j, 1 + i) = v Next writeArray(largestGroupSize + 2, 1 + i) = accepted.TotalFrequency Next Workbooks(BOOK_NAME).Worksheets(SHEET_NAME).Range(WRITE_ADDRESS). _ Resize(UBound(writeArray, 1), UBound(writeArray, 2)).Value = writeArray End Sub 

你会看到我引用了一个名为QSort2D的函数，这个函数只是我经常用来sorting二维数组的一个例程。 如果您想自己sorting，请删除该行。 如果你想要我的sortingfunction，然后离开行，并将以下代码粘贴到您的模块：

 Private Function QSort2D(sortArray As Variant, _ bottomIndex As Long, _ topIndex As Long, _ sortIndex As Long, _ ascending As Boolean) As Variant Dim lowIndex As Long Dim hiIndex As Long Dim swapValue As Variant Dim tempValue As Variant Dim y As Long lowIndex = bottomIndex hiIndex = topIndex swapValue = sortArray((bottomIndex + topIndex) \ 2, sortIndex) Do While lowIndex <= hiIndex If ascending Then Do While sortArray(lowIndex, sortIndex) < swapValue And lowIndex < topIndex lowIndex = lowIndex + 1 Loop Do While sortArray(hiIndex, sortIndex) > swapValue And hiIndex > bottomIndex hiIndex = hiIndex - 1 Loop Else Do While sortArray(lowIndex, sortIndex) > swapValue And lowIndex < topIndex lowIndex = lowIndex + 1 Loop Do While sortArray(hiIndex, sortIndex) < swapValue And hiIndex > bottomIndex hiIndex = hiIndex - 1 Loop End If If lowIndex <= hiIndex Then For y = LBound(sortArray, 2) To UBound(sortArray, 2) tempValue = sortArray(lowIndex, y) sortArray(lowIndex, y) = sortArray(hiIndex, y) sortArray(hiIndex, y) = tempValue Next lowIndex = lowIndex + 1 hiIndex = hiIndex - 1 End If Loop If bottomIndex < hiIndex Then sortArray = QSort2D(sortArray, bottomIndex, hiIndex, sortIndex, ascending) If topIndex > lowIndex Then sortArray = QSort2D(sortArray, lowIndex, topIndex, sortIndex, ascending) QSort2D = sortArray End Function