I have a macro with a loop that references the activecell. This works perfectly when I was building the code. However now I'm tidying up this excel template and am trying to execute this from another worksheet, which is like a menu/control sheet.
Everything works using the With Sheets apart from the part where I call on the activecell. Is there something I need to change?
With Sheets("EU Analysis")
With .Range("C7:I5000")
.Cells.ClearContents
.Borders.LineStyle = xlNone
.Interior.Color = 16777215
End With
With .Range("M7:Q21")
.Cells.ClearContents
End With
With .Range("M23:N27")
.Cells.ClearContents
End With
Dim r3 As Range
Set r3 = .Range("C7:I7")
r3.CopyFromRecordset rst4a
Set r3 = .Range(r3, r3.End(xlDown).End(xlToRight))
With r3
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
RowCount = .Range("C" & Rows.Count).End(xlUp).Row - 6
For i = 7 To RowCount + 6
.Cells(i, 8).Select
If ActiveCell.Value = "" Then
ActiveCell.Value = "New"
ActiveCell.HorizontalAlignment = xlCenter
ActiveCell.Interior.Color = RGB(255, 192, 0)
End If
Next i
For i = 7 To RowCount + 6
.Cells(i, 7).Select
If ActiveCell.Value = "" Then
ActiveCell.Value = "Expired"
ActiveCell.HorizontalAlignment = xlCenter
ActiveCell.Interior.Color = RGB(141, 180, 226)
End If
Next i
End With
Thanks in advance
Related
My code opens workbook, copies, and paste into this main workbook (essentially it consolidates several worksheets from different workbooks) but it crashes and excel closes and re-opens (recover). However when I add breakpoints it runs without issues. The source workbooks have similar layout / headers. It has formatting inside as well hence the copying of formats below. I have tried commenting out the formatting portion, commenting out the ContinueDo portion, and it still crashes. What did i do wrong? This is my code:
Private Sub CommandButton1_Click()
Dim File_Path As String, wsSrce As String
Dim File_Name As String
Dim firstrow, LastRow As Long
Dim wbDst As Workbook, wbSrce As Workbook, New_Workbook As Workbook
Dim wsDst As Worksheet
Dim rng As Range, r1 As Range, r2 As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With
wsSrce = "Part A"
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("Consolidated Data") 'destination sheet
wsDst.Range("A5:AI1048576").Clear
wsDst.Range("AM5:AQ1048576").Clear
wsDst.Range("AS5:BJ1048576").Clear
wsDst.Range("Aj5:al1048576").ClearFormats
wsDst.Range("Ar5:ar1048576").ClearFormats
File_Path = wbDst.Worksheets("Folder Reference").Cells(1, 2) & "\"
File_Name = Dir(File_Path & "*.xls*")
ActiveRow = 5
Do While File_Name <> ""
Set wbSrce = Workbooks.Open(Filename:=File_Path & File_Name, UpdateLinks:=False, Password:="MBIShariah")
For i = 1 To 5
If Left(Worksheets(i).Name, 6) = "Part A" Then
Worksheets(i).Activate
wsSrce_rename = Worksheets(i).Name
End If
Next i
firstrow = 1 + Application.WorksheetFunction.Match("No", Worksheets(wsSrce_rename).Columns("A:A"), 0)
LastRow = wbSrce.Worksheets(wsSrce_rename).Cells(Rows.Count, 8).End(xlUp).Row
If LastRow = 4 Then
GoTo ContinueDo
End If
wbSrce.Worksheets(wsSrce_rename).Range("A" & firstrow & ":AI" & LastRow).Copy
wsDst.Cells(ActiveRow, 1).PasteSpecial xlValues
wsDst.Cells(ActiveRow, 1).PasteSpecial xlFormats
wbSrce.Worksheets(wsSrce_rename).Range("AJ" & firstrow & ":AN" & LastRow).Copy
wsDst.Cells(ActiveRow, 39).PasteSpecial xlValues
wsDst.Cells(ActiveRow, 39).PasteSpecial xlFormats
wbSrce.Worksheets(wsSrce_rename).Range("AO" & firstrow & ":BJ" & LastRow).Copy
wsDst.Cells(ActiveRow, 45).PasteSpecial xlValues
wsDst.Cells(ActiveRow, 45).PasteSpecial xlFormats
LastRowDst = wsDst.Cells(Rows.Count, 8).End(xlUp).Row
Set r1 = wsDst.Range("AJ" & ActiveRow & ":AL" & LastRowDst)
Set r2 = wsDst.Range("AR" & ActiveRow & ":AR" & LastRowDst)
Set rng = Union(r1, r2)
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Application.CutCopyMode = False
ContinueDo:
ActiveRow = 1 + wsDst.Cells(1048576, 8).End(xlUp).Row
wbSrce.Close savechanges:=False
' Kill File_Path & File_Name
File_Name = Dir()
Loop
wsDst.Activate
wsDst.Cells(1, 1).Select
'ActiveWorkbook.RefreshAll
MsgBox "Data copied."
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
I have a table from Column A to Column M where I will input new row of data everyday. I have a Macro which enables me to highlight selected cells in Column I and sum to column J including merge. However, I would like to add "Thick Bottom Border" from Column A to Column M after triggering the Macro. In addition, it would be a better if the Selection Cells will go to Column C 1 row below for faster data input.
Image below for your reference:
Expected Result:
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+l
Dim mergeCells As Range
Set mergeCells = selection.Offset(, 1)
With mergeCells
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.Formula = "=SUM(" & selection.Address & ")"
End With
End Sub
If you run the macro recorder, and add your border, you should get something along the lines of:
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
And now that you know how to add a border, you just need to specify the range.
One way would be to get the last row of your selection. Which can be done by looking at the starting row, the amount of selected rows, and then subtracting one, since we are essentially counting the first row twice.
lrow = Selection.Row + Selection.Rows.Count - 1
Since the range in where you want this will always be the same, it's easy enough to hard-code it, by concatenating the Column and the row, using &.
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+l
Dim lRow as Long
Dim mergeCells As Range
Set mergeCells = selection.Offset(, 1)
With mergeCells
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.Formula = "=SUM(" & selection.Address & ")"
End With
lRow = Selection.Row + Selection.Rows.Count - 1
With Range("A" & lRow, "M" & lRow).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
End Sub
I have wrote a code which paste the borders on Sheet1 used range whenever i make an entry and same for Sheet2. The data is cover by borders automatically.
I have been facing an error (select method of range class failed) if i apply the both codes in sheet1 and Sheet2.
If i use the code for single sheet it works.
Is there an way to merge these both codes OR any way to make it work OR to do this thing in an efficient way.
Any help will be appreciated.
Sheet1
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = Sheet1.UsedRange.Rows.Count
lngLstCol = Sheet1.UsedRange.Columns.Count
For Each rngCell In Range("A2:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet2
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
lngLstRow = Worksheets("Current Stock").UsedRange.Rows.Count
lngLstCol = Worksheets("Current Stock").UsedRange.Columns.Count
For Each rngCell In Range("A2:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
End If
Next
Application.ScreenUpdating = True
End Sub
If i use the code for single sheet it works.
This might be because you are not fully qualifying ranges: If you don not qualify Cells and Range it works on the activesheet so you need to pre-qualify wuith the sheet that contains the ranges so target.parent.Cells and target.parent.range might solve your problem
Is there an way to merge these both code
Define a sub which takes a worksheet as a parameter
sub do_the_work(byref ws as worksheet)
Application.ScreenUpdating = False
lngLstRow = Worksheets("Current Stock").UsedRange.Rows.Count
lngLstCol = Worksheets("Current Stock").UsedRange.Columns.Count
For Each rngCell In ws.Range("A2:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
ws.Range(ws.Cells(r, c), ws.Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
End If
Next
Application.ScreenUpdating = True
end sub
then inside the worksheet.change call
Private Sub Worksheet_Change(ByVal Target As Range)
do_the_work target.parent
End Sub
Improvement removing select
With ws.Range(ws.Cells(r, c), ws.Cells(r, lngLstCol))
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Font
.Name = "Calibri"
.Size = 10
End With
End With
Summary: Find text/string based on list in another sheet and adjust trailing zeros with border around the range.
The excel workbook containing two sheet.
Sheet1 Name: List (having column A with text/string to be find and column B having numerical value) as in first image.
Sheet2 Name: "Raw" containing text anywhere and below numerical value with different decimal points. Also having few blank rows between set of range as in image 2.
I have recorded macro and tried to edit it. This macro working for Text1. Below macro find text1 in "raw" sheet and adjust the display of trailing zeros based on B1 value of list sheet.
How to loop the all listed text in column A of sheet list and adjust display of trailing zeros with outside borders. Output in image 3. Find as xlpart.
Sheet1 or list
Sheet2 or another sheet
Output
Sub Macro1()
Dim sFirstAddress As String
Dim rng As Excel.Range
With Sheets("Raw").Range("A1:DZ1000") '.UsedRange ???
'how to loop for list of text/string present in column A as in image 1.
Set C = .Find(What:="Text1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'how to loop for number in column B for adjusting/Keeping trailing zero's
If Sheets("List").Range("B1") = 1 Then
Selection.NumberFormat = "0.0"
Else
If Sheets("List").Range("B1") = 2 Then
Selection.NumberFormat = "0.00"
Else
If Sheets("List").Range("B1") = 3 Then
Selection.NumberFormat = "0.000"
End If
End If
End If
Selection.End(xlDown).Select
Cells.FindNext(After:=ActiveCell).Activate
Set C = .FindNext(C)
If C Is Nothing Then
GoTo DoneFinding
End If
Loop While C.Address <> FirstAddress
End If
DoneFinding:
End With
End Sub
By doing trial and error continuously for 6 hours, I am able to loop both columns of list sheet and output as expected. Below code working perfectly.
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim Rng As Range
Dim I As Long
Dim item As Range
For Each item In Sheets("List").UsedRange.Columns("A").Cells
MySearch = Array(item.Value2)
If item.Value2 = "" Then
Exit Sub
Else
With Sheets("Raw").UsedRange 'Range("B1:AA10000")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), After:=.Cells(.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
With Rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 0
.TintAndShade = 0
End With
Rng.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If item.Offset(, 1).Value2 = 1 Then
Selection.NumberFormat = "0.0"
Else
If item.Offset(, 1).Value2 = 2 Then
Selection.NumberFormat = "0.00"
Else
If item.Offset(, 1).Value2 = 3 Then
Selection.NumberFormat = "0.000"
Else
If item.Offset(, 1).Value2 = 4 Then
Selection.NumberFormat = "0.0000"
End If
End If
End If
End If
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End If
Next
End Sub
I have a problem creating a formula or VBA macro that sorts 'preference voting' data into appropriate groups for students selecting summer camp electives. Historically, we've done the voting and sorting on paper, and i'd like to move to something a little less time consuming for the many, many rounds of electives we do at camp.
Ive created a form they fill out, which gives me a spreadsheet with their elective preferences. it looks like this
Kids A B C
1001 2 3 1
1002 3 1 2
1003 3 1 2
1004 3 1 2
1005 3 1 2
1006 3 1 2
1007 3 2 1
1008 3 2 1
1009 2 1 3
1010 3 1 2
1011 2 1 3
what id like to be able to do is run a macro or (even better) a dynamic function that sorts the voters into categories - like this
A B C
1001 1002 1007
1010 1003 1008
1011 1004 1009
1005
1006
basically - elective A has no first choice votes so its initial count = 0. Elective B has 8 first choice votes, so its initial count is 8, elective c has 3 first choice votes so its initial count is 3. I need these to be at least close to balanced (plus i actually have over 100 students), so we have 2nd choices also (3rd is a strike). so the minimum count for each group needs to be 1/4 + 1 total voting population.
Obviously no solution is perfect, because theres an inherently subjective choice about who gets moved from their first choice to their second, but any help would be appreciated.
If theres something in stat math that would point me in the right direction that would help too. ive tried googling this, but all references to voting systems i can find assume i want to anonymise the data, which is the opposite of what i need.
ive tried vlookups and indexing, but the formulas quickly get unwieldy, and dont seem to do what i need anyway. SORT functions seem to be the way to go, but i cant wrap my head around the syntax of them (using just visual sort is how ive rendered the above sorting.) RANK doesnt seem to offer what im looking for.
I have simulated the voting process and created somehow equal groups of kids based on their preferred choices.
If anything is unclear please leave a comment and I will do my best to better explain the content.
Note(disclaimer hehe): I would have done this using only Types, Collections and arrays, however the ability to demonstrate visual representation of my solution required me to use spreadsheet. The code used in this example can easily be modified not to work with spreadsheets but Collections.
Here's what I have done in steps:
1 - Setup spreadsheet (spreadsheet name: "Sheet1", module name: Formatting)
2 - Randomized Voting Process (module name: RandomVotes)
3 - Calculations Step 1 (module name: Step1)
4 - Calculations Step 2 (module name: Step2)
Step 1
Note: you can skip this step and step2 if you already have the results of voting in the following format:
Kids is column A
A is column B
B is column C
C is column D
Your initial spreadsheet should look like the below screenshot
You can manually make it look like this although I have recorded a macro that formats your spreadsheet to the standards required for the macro to work properly. Copy-paste the below code to a new module and rename it(rename the module) to Formatting execute the below code(press F5 to execute)
Sub FormatSpreadsheet()
Application.ScreenUpdating = False
Cells.Select
With Selection.Font
.Name = "Consolas"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection.Font
.Name = "Consolas"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A1").Select
ActiveCell.FormulaR1C1 = "Kids"
Range("B1").Select
ActiveCell.FormulaR1C1 = "A"
Range("C1").Select
ActiveCell.FormulaR1C1 = "B"
Range("D1").Select
ActiveCell.FormulaR1C1 = "C"
Range("A2").Select
ActiveCell.FormulaR1C1 = "1"
Cells.Select
Selection.NumberFormat = "#"
Range("A2").Select
ActiveCell.FormulaR1C1 = "0001"
Range("A3").Select
ActiveCell.FormulaR1C1 = "0002"
Range("A4").Select
ActiveCell.FormulaR1C1 = "0003"
Range("A2:A4").Select
Selection.AutoFill Destination:=Range("A2:A47"), Type:=xlFillDefault
Range("A2:A47").Select
Range("B1:D1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Columns("A:P").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B1:D1").Select
Selection.Copy
Range("F1").Select
ActiveSheet.Paste
Range("J1").Select
ActiveSheet.Paste
Range("N1").Select
ActiveSheet.Paste
Range("H7").Select
Application.CutCopyMode = False
Range("B:D,F:F,G:G,H:H,J:J,K:K,L:L,N:N,O:O,P:P").Select
Range("P1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.14996795556505
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.14996795556505
.Weight = xlThin
End With
Range("B1:D1,F1:H1,J1:L1,N1:P1").Select
Range("N1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("E1").Select
ActiveCell.FormulaR1C1 = "1st choice"
Range("I1").Select
ActiveCell.FormulaR1C1 = "2nd choice"
Range("M1").Select
ActiveCell.FormulaR1C1 = "3rd choice"
Range("E:E,I:I,M:M").Select
Range("M1").Activate
Selection.ColumnWidth = 12.13
Range("E1:H1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Range("E1:H1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Range("I1:L1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E1:H1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("M1:P1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 13434879
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E1,I1,M1").Select
Range("M1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
Application.ScreenUpdating = True
End Sub
You spreadsheet now should like like the below screenshot
Note: column A goes down to number 0046 (row 47) so, if you have more kids then add more numbers before continuing.
Step 2
Add a new Module and name it RandomVotes
Copy-Paste and then execute (F5) the code to get results.
The code will simulate a voting process and print results in columns B to D:
Sub RandomizeVotes()
Application.ScreenUpdating = False
Dim i As Long, j As Long
Dim r As Range, nxtRnd As Long
Dim rowComplete As Boolean
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("B" & i)
r = GetRandom
Do Until rowComplete
r.Offset(0, 1) = GetRandom
r.Offset(0, 2) = GetRandom
If r <> r.Offset(0, 1) And r <> r.Offset(0, 2) And r.Offset(0, 1) <> r.Offset(0, 2) Then rowComplete = True
Loop
Set r = Nothing
rowComplete = False
Next i
Application.ScreenUpdating = True
End Sub
Function GetRandom() As Long
Randomize
Dim x As Double
x = Rnd
If x < 0.3 Then
GetRandom = 1
ElseIf x >= 0.3 And x < 0.6 Then
GetRandom = 2
ElseIf x >= 0.6 Then
GetRandom = 3
End If
End Function
At this point, go back to your spreadsheet it should give you the following results:
Note: I said you can skip this step if you already have your voting results in the format specified above. I would recommend following all steps just to see how things work.
Step3
Add a new Module, name it Step1.
Copy-Paste the below code and again: execute it.
This code will populate columns F:P based on kids choices
Option Explicit
' Choices columns
Sub Step_1()
Dim i As Long
Dim r As Range
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("B" & i)
' first choices
If r = 1 Then
r.Offset(0, 4) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 1) = 1 Then
r.Offset(0, 5) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 2) = 1 Then
r.Offset(0, 6) = r.Offset(0, -1).Text
End If
' second choices
If r = 2 Then
r.Offset(0, 8) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 1) = 2 Then
r.Offset(0, 9) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 2) = 2 Then
r.Offset(0, 10) = r.Offset(0, -1).Text
End If
' third choices
If r = 3 Then
r.Offset(0, 12) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 1) = 3 Then
r.Offset(0, 13) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 2) = 3 Then
r.Offset(0, 14) = r.Offset(0, -1).Text
End If
Set r = Nothing
Next i
deleteEmpties
End Sub
Private Sub deleteEmpties()
Application.ScreenUpdating = False
Dim i As Long, j As Long
For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
For j = 16 To 6 Step -1
If IsEmpty(Cells(i, j)) Then Cells(i, j).Delete Shift:=xlUp
Next j
Next i
Application.ScreenUpdating = False
End Sub
The result should look similar to the below screenshot (if you have randomized choices than it will look different)
Step 4
Add a new Module, name it Step2.
Copy-Paste the below code and again: execute it.
This code will re-populate columns F:H. This pretty much (and hopefully ;) ) achieves what you were looking for.
At this point, your column F:H are sorted by kids numbers. To add more although intentional randomness to the process you can re-sort the numbers. For example instead of
0002
0005
0010
0013
0017
0021
0022
0025
0026
0038
0043
you can do
0038
0005
0026
0013
0017
0022
0021
0002
0010
0025
0043
You will see what I mean when we get to the algorithm that will even out the groups.
My solution to even out the groups of kids:
find out roughly how many kids per group ( total / 3 )
find group with the highest preferred count
get the first in the list [starting from the end of the list] (thats why randomizing columns order may be a good idea)
find kid's second choice and move him to that column
for example:
Since the group B is the highest preferred group we need to move some people off of it in order to even out the other ones.
Each time we have to check the size of groups. Once they come close to each other we stop moving kids around.
Take the first kid 0001 and check whether his 2nd choice is the lowest group. If it's a false then we move to the next one, and keep moving until we find one kid who's second choice is the lowest group (A in my example ).
'0011' and '0012' match our criteria so we can move them to the lowest group.
Checking for the length of the size of the most preferred group again.
and so on results in this Step2 Module code:
Option Explicit
Type Group
Name As String
Column As String
Size As Long
End Type
Type Number
Total As Long
Average As Long
HiBound As Long
LoBound As Long
End Type
Type Child
Id As String
Choice1 As String
Choice2 As String
Choice3 As String
End Type
Public A As Group
Public B As Group
Public C As Group
' moving based on the second preference
Sub Step_2()
Dim T As Number
A.Name = "A"
A.Column = "F"
A.Size = Range("F" & Rows.Count).End(xlUp).Row
B.Name = "B"
B.Column = "G"
B.Size = Range("G" & Rows.Count).End(xlUp).Row
C.Name = "C"
C.Column = "H"
C.Size = Range("H" & Rows.Count).End(xlUp).Row
T.Total = Range("A" & Rows.Count).End(xlUp).Row
T.Average = T.Total / 3
T.HiBound = T.Average + 1
T.LoBound = T.Average - 1
Dim i As Long, j As Long, k As Long
Dim kidChoice As Range, kidId As Range
For i = Range("" & getBiggest.Column & "" & Rows.Count).End(xlUp).Row To 2 Step -1
A.Size = Range("F" & Rows.Count).End(xlUp).Row
B.Size = Range("G" & Rows.Count).End(xlUp).Row
C.Size = Range("H" & Rows.Count).End(xlUp).Row
If Range("" & getBiggest.Column & "" & Rows.Count).End(xlUp).Row = T.Average Or _
Range("" & getSmallest.Column & "" & Rows.Count).End(xlUp).Row = T.Average _
Then
Exit For
Else
For k = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
Set kidChoice = Range("" & getBiggest.Column & "" & i)
Set kidId = Range("A" & k)
Dim kid As Child
kid.Id = kidId.Text
kid.Choice1 = getBiggest.Name
If StrComp(kidChoice.Text, kidId.Text, 1) = 0 Then
For j = 1 To 3
If kidId.Offset(0, j) = 2 Then
kid.Choice2 = Cells(1, j + 1).Text
End If
If kidId.Offset(0, j) = 3 Then
kid.Choice3 = Cells(1, j + 1).Text
End If
Next j
If kid.Choice2 = getSmallest.Name Then
' transfer groups
Dim nxtSmall As Long
nxtSmall = Range("" & getSmallest.Column & "" & Rows.Count).End(xlUp).Row + 1
Range("" & getSmallest.Column & "" & nxtSmall).Value = kid.Id
kidChoice.Delete Shift:=xlUp
End If
End If
Set kidId = Nothing
Next k
Set kidChoice = Nothing
End If
Next i
End Sub
Private Function getBiggest() As Group
If A.Size > B.Size And A.Size > C.Size Then
getBiggest = A
ElseIf B.Size > A.Size And B.Size > C.Size Then
getBiggest = B
ElseIf C.Size > A.Size And C.Size > B.Size Then
getBiggest = C
ElseIf A.Size = B.Size Or A.Size = C.Size Then
getBiggest = A
ElseIf B.Size = A.Size Or B.Size = C.Size Then
getBiggest = B
ElseIf C.Size = A.Size Or C.Size = B.Size Then
getBiggest = C
End If
End Function
Private Function getSmallest() As Group
If A.Size < B.Size And A.Size < C.Size Then
getSmallest = A
ElseIf B.Size < A.Size And B.Size < C.Size Then
getSmallest = B
ElseIf C.Size < A.Size And C.Size < B.Size Then
getSmallest = C
ElseIf A.Size = B.Size Or A.Size = C.Size Then
getSmallest = A
ElseIf B.Size = A.Size Or B.Size = C.Size Then
getSmallest = B
ElseIf C.Size = A.Size Or C.Size = B.Size Then
getSmallest = C
End If
End Function
Final result
And the final result of the equating the groups of kids preferred choices:
I really hope this helps!
Summary
If your sheet already looks like
then run Step_1 and then Step_2
I have ran this a few times for testing purposes, here are some sample results
Your sample
Random Votes + primary split into columns . Obviously, it isn't printing exactly the same results as you provided in your sample. You have already said there is no perfect solution. its ran on only 11 kids and you have said you have 100+. I think it does the job though and functions as expected
executed Step_1
Result
Sample 1
Random Votes + primary split into columns
executed Step_1
Result
Sample 2
Random Votes + primary split into columns
executed Step_1
Result
Sample 3
Random Votes + primary split into columns
executed Step_1
Result