Группировка примерно одинаковых размеров в VBA

Question

Я новичок в программировании в VBA, и мне было интересно заполнить небольшой проект, который я заполнил на бумаге в код.

Задача: С учетом набора данных из 26 строк (по алфавиту А-З) и их соответствующего количества записей группируйте их в n групп (n> 0) в равной степени на основе подсчета, где каждая буква уникальна для этой группы. Поэтому, если в группе 1 были A, B, C, тогда другие группы не могут использовать эту букву.

Когда я решил эту одну бумагу это был мой мыслительный процесс:

1. Скопируйте данные на другой части страницы, так что я могу манипулировать данными.
2. Sum общее количество для всех записей (AutoSum A ~ Z_count)
3. Сортировки данных на основе общего количества записей, наибольшие к наималейшим
4. НАЙДИТЕ проценты от общей суммы для каждой записи (кол/всего)
5. Эгоистично распределять данные так, чтобы, когда общая сумма процентов данных группы меньше, чем total_percent/количество групп, начинают проверять каждую букву и сохранять эти данные на листе excel в стороне от основных данных.

Ниже приведен мой псевдокод для этой проблемы в C++ и данные, которые я использовал и решил вручную. Как я уже сказал, я очень новичок в VBA, поэтому я бы хотел создать макрос, который автоматически разрешит это, если у меня когда-нибудь будет другой документ в будущем.

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. https://drive.google.com/file/d/0Bz2sgKh9NVmVUGlfZ1NETlJwaTg/view?usp=sharing

Answer 1

Я хотел бы ответить на этот вопрос, потому что это хорошая возможность объяснить некоторые из возможностей VBA. Генератор макрокода имеет место в записи нажатий клавиш, но так много сообщений здесь - это просто пасты автоматически сгенерированного кода с вопросом вроде: «Как это сделать?»

Это правда, что те, кто хочет разрабатывать приложения, не будут использовать VBA, но это не значит, что VBA - это меньший язык. VBA действительно довольно приличный ... при условии, что разработчик отходит от записи нажатий клавиш и погружается в воду объектно-ориентированного программирования.

Реальная сила VBA возникает, когда разработчик 1) считывает данные из Excel, 2) завершает всю обработку данных и 3) только затем записывает результаты обратно в Excel.

В приведенном ниже коде показано, как VBA может сделать это с заданной задачей. Я должен сказать, что я не думаю, что ваши шаги - лучшее решение для этой задачи, но я оставлю это вне этой публикации. То, что я могу показать вам, это не то, как переводить ваш псевдокод непосредственно в VBA, но как вы можете использовать некоторые объекты VBA для достижения того же. Кстати, я не думаю, что ваш псевдокод соответствует вашему рукописному решению - если вы возьмете группу 1, например: 'S' + 'C' = 0.1683710, тогда как ваш код не будет принимать никакого значения выше 0.1666667, поэтому 'S' и ' C 'не будет делать одну и ту же группу программно.

Во всяком случае, к коду ...

Прежде всего, добавьте два Class Modules (Insert -> Module Class).Назовите первую 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, которая является обычной процедурой, которую я часто использую для сортировки 2-мерных массивов. Если вы хотите сделать свою собственную сортировку, удалите эту строку. Если вы хотите, чтобы моя функция сортировки оставила строку и вставила следующий код в ваш модуль:

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