Макрос для выделения x строк данных x количеству людей, а затем цветовой код

У меня есть задача, которую я выполняю. Я хочу автоматизировать относительно большой набор данных. По сути, у меня есть список записей, которые мне нужно назначить группе людей, а затем соответствующим образом покрасить эти назначения.

Не существует установленного количества записей, поэтому количество строк является переменной. Количество людей также является переменной величиной.

Записи находятся в столбце А. Люди находятся в колонке E.

Если имеется 1000 записей и 20 человек, назначьте 50 записей на человека, введя его имя в столбец C.

Итак, как я могу создать макрос, который будет:

1- подсчитайте количество записей и разделите на количество людей
2- используйте это число в качестве количества записей для назначения каждого человека и введите имя человека в столбце C
3- назначьте каждому человеку свой цвет заливки и цвет шрифта, чтобы различать друг друга. (можно ли назначить одинаковую цветовую схему для каждого имени в столбце C и столбце E?)

вот пример того, что я хочу сделать

что ты уже испробовал?

Ricardo Diaz 14.12.2020 01:14

Это похоже на Эксель. Вы используете Excel или базу данных?

braX 14.12.2020 01:16

я использую Эксель. я должен удалить тег базы данных

maestro 14.12.2020 02:05
Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
0
3
363
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Это интересный проект. Код ниже даст вам (в основном) то, что вы ищете. Проблема с форматированием заключается в том, что, хотя можно генерировать случайные форматы, вы можете получить (например) зеленый на зеленом, что непригодно для использования. Таким образом, код копирует любые форматы, которые вы установили для имени каждого человека в столбце E, во все соответствующие ячейки в столбце C.

Я протестировал следующий код с 10 000 записей и 17 людьми, каждый из которых использовал разные форматы. Он пробежал менее чем за 1 секунду. Дайте мне знать, как вы с этим справляетесь.

Option Explicit
Sub AssignTasks()
Dim Records As Long, PasteTo As Long, People As Integer, LastP As Long
Dim balance As Integer, base As Integer, hard As Integer, p As Range
Dim AllRng As Range, BaseStart As Integer
Application.ScreenUpdating = False
 
People = Cells(Rows.Count, 3).End(xlUp).Row
If People <> 1 Then
    ActiveSheet.Range("C2:C" & People).Clear
End If

People = Cells(Rows.Count, 5).End(xlUp).Row
On Error Resume Next
ActiveSheet.Range("E2:E" & People).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0

Records = Cells(Rows.Count, 2).End(xlUp).Row - 1
People = Cells(Rows.Count, 5).End(xlUp).Row - 1

base = Application.WorksheetFunction.RoundDown(Records / People, 0)
balance = Records - (People * base)
hard = base + 1

ActiveSheet.Range("E2:E" & balance + 1).Name = "hardrng"
ActiveSheet.Range("E" & balance + 2 & ":E" & People + 1).Name = "easyrng"

If balance = 0 Then GoTo SkipHard

For Each p In ActiveSheet.Range("hardrng")    
    PasteTo = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Set AllRng = ActiveSheet.Range("C" & PasteTo)
    AllRng.Resize(hard, 1).Value = p.Value    
Next p

SkipHard:
For Each p In ActiveSheet.Range("easyrng")    
    PasteTo = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Set AllRng = ActiveSheet.Range("C" & PasteTo)
    AllRng.Resize(hard - 1, 1).Value = p.Value    
Next p

'Copy the formats
People = Cells(Rows.Count, 5).End(xlUp).Row
LastP = Cells(Rows.Count, 3).End(xlUp).Row

For Each p In ActiveSheet.Range("E2:E" & People)        
    Sheet1.Range("C:C").AutoFilter Field:=1, Criteria1: = "" & p
    p.Copy
    On Error Resume Next
        Sheet1.Range("C2:C" & LastP).SpecialCells(xlCellTypeVisible).PasteSpecial xlFormats            
    On Error GoTo 0
    Application.CutCopyMode = False    
Next p

Sheet1.AutoFilterMode = False    
Application.ScreenUpdating = True
End Sub

Обратите внимание, что вы говорите, что записи находятся в столбце A, но ваше изображение показывает их в столбце B. В этом коде используется столбец B — его легко изменить.

ух ты. спасибо. я читаю код, чтобы попытаться понять, как он работает, и это будет действительно полезно для меня, когда я буду продвигаться в vba ... очень умное решение с форматированием. я получаю сообщение об ошибке компиляции: синтаксическая ошибка в этом разделе, поскольку он копирует форматы из столбца E .. есть идеи, почему? Sheet1.Range("C2:C" & LastP).SpecialCells(xlCellTypeVisible).PasteSpecial , Вставить:=xlPasteFormats

maestro 18.01.2021 01:06

Выполняется ли код до этой точки, а затем останавливается - или он вообще не будет работать?

user3259118 18.01.2021 01:18

он вообще не запускается, поэтому я удалил часть «Копировать форматы», и в остальном он работает отлично. эта вещь прекрасна, спасибо большое

maestro 18.01.2021 01:21

ага. работает как шарм. любопытно, но почему в этом разделе вы называете вкладку Sheet1.Range, а не ActiveSheet.Range?

maestro 18.01.2021 01:49

Вы совершенно правы, нужно было использовать то или другое повсюду. Sheet1 был бы лучшим.

user3259118 18.01.2021 02:08

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

maestro 18.01.2021 02:16

Во что бы то ни стало - по электронной почте.

user3259118 18.01.2021 02:17

Другие вопросы по теме