I have a list of tournament competitors. If the list of competitors exceeds 12 then I need to split the list as equally as possible over 2 tournament rings (ie, if 13 then 7 in 'Ring 1' and 6 in 'Ring 2'). The varibles that dictate how the competitors are split are contained in cell D35 & D37. So I need a piece of code that looks at the value in cell D35 and then carries out a copy a paste sequence (to populate the Ring 1 range) THAT many times. It then needs to do the same for the value shown in D37. Can anyone help with this. I've had a look around on here and the NET and I'm still struggling.
Also, how do I post a sample of my workbook to show what I'm trying to do with the above question??
Kind Regards
Andy
Just split your task in some simple tasks:
-Check if more than 12 competitors
-if more than 12, divide in 2 rings; if not only use 1 ring
-copy the competitors, paste them in the specified ring
(i did not really understand what you meant with your variables ind D35 and D37, however i am not yet allowed to make comments to your post. I will alter this answer if you comment)
I am assuming your list of competitors starts in Cell A1
Sub process()
Dim countCompetitors As Integer
Dim amountRing1 As Integer
Dim amountRing2 As Integer
Dim rng1 As Range
Dim rng2 As Range
countCompetitors = 1
'count the amount of competitors
While Not IsEmpty(ActiveSheet.Cells(countCompetitors, 1))
countCompetitors = countCompetitors + 1
Wend
countCompetitors = countCompetitors - 1
If countCompetitors Mod 2 = 0 Then
'amount of competitors is even
amountRing1 = countCompetitors / 2
amountRing2 = countCompetitors / 2
Else
'amount of competitors is odd
amountRing1 = countCompetitors / 2
amountRing2 = countCompetitors / 2 - 1
End If
'rng1 and rng2 now contain the competitors
Set rng1 = ActiveSheet.Range(Cells(1, 1), Cells(amountRing1, 1))
Set rng2 = ActiveSheet.Range(Cells(amountRing1 + 1, 1), Cells(amountRing1 + amountRing2, 1))
'copy ring1 in column B and ring2 in column C
rng1.Copy ActiveSheet.Range("B2")
rng2.Copy ActiveSheet.Range("C2")
End Sub
I hope i could help you a bit with that, as already mentioned, please explain what you mean with the variables in Cells D35 and D37, I will alter my code accordingly ;)
Related
wondering if anyone can help.
I'm a CS teacher and as a part of my current Y10 scheme we're looking at how images are represented by binary. I've created a file that encourages the user to recreate some pixel art based on the binary code provided.
However - now this is where I'm completely stuck - I'm trying to create a macro that allows the user to check whether their colours match what the final result will be. I understand how to compare the two colours, but getting it to work in the large range I have is where it's falling down.
The code I've got so far is:
Function Inc(ByRef i As Long)
i = i + 1
End Function
Sub CompareCellColors()
Dim Rng1 As Range
Set Rng1 = Range("C1:O19")
Dim Rng2 As Range
Set Rng2 = Range("AC1:AO19")
Dim x As Long
x = 0
For Each c1 In Rng1
For Each c2 In Rng2
If c1.Interior.ColorIndex = c2.Interior.ColorIndex Then
Inc x
End If
Next c2
Next c1
If x = 247 Then
Range("A3").Value = True
Else
Range("A3").Value = False
End If
End Sub
I've included my attempt at a workaround (incrementing a variable if they match) but this doesn't work either.
The program compiles and runs, but doesn't accurately compare the two cell ranges (hopefully that explanation makes sense!). The current result of the x increment is 61009, however the selection only has 247 cells.
You are comparing every pixel in Rng1 to every pixel in Rng2 because the loops are nested. I believe what you want is to compare on a more one-to-one basis. Try instead
For a = 1 to 19 'rows
for b = 3 to 13 'columns
If Cells(a, b).Interior.ColorIndex = Cells(a, b + 29).Interior.ColorIndex Then
Inc x
End If
Next b
Next a
I have an excel sheet containing entities, their characteristics, a value for the characteristic and a total as follows:
Entity CHAR1 CHAR2 CHAR3 CHAR4 Total
1 10 20 5 5 40
2 5 100 30 25 160
3 25 25 10 20 80
Now I want to replace the values with percentages in which the total column is seen as 100% for each row seperately.
This would in this example result in:
Entity CHAR1 CHAR2 CHAR3 CHAR4
1 25 50 12,5 12,5
2 3,125 62,5 18,75 15,625
3 31,25 31,25 12,5 25
As my data-set is pretty big i'm wondering if there is a fast solution to do this? I get stuck because placing a formula in each cell will require calculating the new value using the old value in the cell itself. And using a new worksheet might give me some performance issues.
Thanks in advance
Run this sub and all should work as you asked (note that you need to define the TotalColumn column number (since it isn't evident in the example)
Sub MakePercent()
Dim Cell As Range, CalcRange As Range, TotalColumn As Variant
TotalColumn = 'Write the column number or letter here
Set CalcRange = ActiveSheet.Range(ActiveSheet.Cells(2,2), ActiveSheet.Cells(ActiveSheet.UsedRange.Rows.Count,TotalColumn - 1))
For Each Cell In CalcRange
Cell.Value = CDbl(Cell.Value) / CDbl(ActiveSheet.Cells(Cell.Row,totalColumn))
Next Cell
End Sub
Minor update from myself:
The macro as provided by RGA worked fine, until I expanded my data with some extra columns. It then caused excel to freeze and therefore i went looking for a new solution.
If found the following stackoverflow question and adding Application.ScreenUpdating = false to the beginning and Application.ScreenUpdating = true to the end of the macro resolved the freezing issue.
This leads to the following code:
Sub MakePercent()
Application.ScreenUpdating = False
Dim Cell As Range, CalcRange As Range, TotalColumn As Variant
TotalColumn = 'Write the column number or letter here
Set CalcRange = ActiveSheet.Range(ActiveSheet.Cells(2,2), ActiveSheet.Cells(ActiveSheet.UsedRange.Rows.Count,TotalColumn - 1))
For Each Cell In CalcRange
Cell.Value = CDbl(Cell.Value) / CDbl(ActiveSheet.Cells(Cell.Row,totalColumn))
Next Cell
Application.ScreenUpdating = True
End Sub
I want to copy the cells "A2:A" & patientprofiles + 1 and paste them in the first unused row in column D (i.e., there should be no blank cells between what's already in column D and what I want to paste there, but I also don't want to paste over what's already there). I then want to repeat this process a user-defined number of times (this variable will be called g1_observations). I then want to copy the cells "A" & patientprofiles + 2 & ":A" & 2 * patientprofiles + 1 to the new last used row in column D (i.e., taking into account that I've just pasted patientprofiles number of cells g1_observations number of times at the bottom of column D. I want to continue repeating this process a user-defined number of times (this number of times is defined by the variable numberofgrids).
For example: imagine that the user has defined that there will be three grids. Grid 1 will have 2 observations, Grid 2 will have 3 observations, and Grid 3 will have 4 observations. Also imagine that patientprofiles has been set to 40.
If this is the case, there will already be values in cells D1:D121, so I want to begin pasting in D122. I want to paste the cells A2:A41 (40 cells because patientprofiles = 40) to cells D122:D161; I want to paste the cells A42:A81 to cells D162:D201 and again to D:202:D241; and I want to paste cells A82:A121 to cells D242:D281, again to cells D282:D321, and again to cells D322:D361. I'm pasting each "grid" one less time than the number of observations for that grid, because the first group of observations for all grids is what's contained in cells D2:D121. End example
I'm pretty sure I need to use a nested For...Next loop in order to do this, but I'm having trouble with both the inner and outer loop. I think the outer loop should go something like this:
Dim i as long
For i = 0 to numberofgrids - 1
[insert inner loop here]
Next
As far as the inner loop goes, I'm not really sure what I'm doing because it keeps pasting over itself when I am pasting from two grids. The current code I have uses repeated For...Next loops and doesn't work:
Dim myLastRow as Integer
myLastRow = Worksheets("Work").UsedRange.Rows.Count
Dim j as Long
For j = 1 To g1_observations - 1
If j = 1 Then
Range(Cells(2, 1), Cells((patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells(j * myLastRow + 1, 4)
ElseIf j > 1 Then
Range(Cells(2, 1), Cells((patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells((j + 1) * (myLastRow / 2) + 1, 4)
Else: Range("A1").Select
End If
Next
For j = 1 To g2_observations - 1
If j = 1 Then
Range(Cells(patientprofiles + 2, 1), Cells((2 * patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells(j * myLastRow + 1, 4)
ElseIf b > 1 Then
Range(Cells(patientprofiles + 2, 1), Cells((2 * patientprofiles + 1), 1)).Copy _
Destination:=Worksheets("Work").Cells((b + 1) * (myLastRow / 2) + 1, 4)
Else: Range("A1").Select
End If
Next
It pastes over itself, and sometimes it skips lines. I can't really figure out how to reconcile myLastRow with a loop.
I think the inner loop should probably start off something like this:
Dim j as Long
For j = 0 to gj_observations - 1
Range(Cells(j * XXX + 2, 1), Cells((j + 1) * patientprofiles + 1).Copy _
Destination:=Worksheets("Work").Cells(myLastRow * j + 1) , 4
but I'm having difficulty because the variables are called g1_observations, g2_observations, g3_observations, etc., all the way up to g10_observations, and obviously gj_observations won't work. I want to loop on the number between "g" and "_", but I don't know how to get VBA to read variables that way, or if that's possible at all.
Can anyone help me out here? My mind is spinning from trying to understand the concept of loops, especially with different variables at each level.
Also, side question, how do you tell VBA to do nothing in an If statement? I currently have it selecting A1 by writing Else: Range("A1").Select, but I'm sure there's a better way of doing it.
When you're writing macros, it's a better practice to work with ranges and avoid manipulating cells one at a time in a loop. Your macro will run much faster and the code will be clearer.
If you want to create a set of variables that you can access by number, you would use something called an array. This is a pretty fundamental concept that exists in almost every programming language, so I'll refer you to MSDN or your favorite VBA language reference guide for more details.
Dim ws As Worksheet
Dim lr As Long ' Last Row
Dim szpp As Long ' Size (rows) patient profiles
Dim szgobsrv(2) As Long ' Size (rows) observation groups
Dim i As Long
Dim j As Long
Dim SourceCells As Range
Dim TargetCell As Range
Set ws = Sheets("Work")
szpp = 40
szgobsrv(0) = 1
szgobsrv(1) = 2
szgobsrv(2) = 3
For i = 0 To UBound(szgobsrv)
lr = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
' copy the patient profile cells multiple times depending on group size
For j = 0 To szgobsrv(i) - 1
Set SourceCells = ws.[A2].Offset(i * szpp).Resize(szpp)
Set TargetCell = ws.[D1].Offset(lr + j * szpp)
SourceCells.Copy TargetCell
Next
Next
Note the usage of the Resize and Offset methods. These are helpful Range methods that can change the size and position of a range by a fixed amount.
The main problem you are having with values being over written is that youre not using Offset.
Another important thing to remember about nested loops is that the nested loop runs i times per loop of the upper level loop. I am thinking that nested loops here might not be good for you. You could probably just make them all independent loops?
If you want to loop to the number contained within the variable you might want to set that variable equal to a number.
example:
g2_observations =2
For j = 1 To g2_observations - 1
Aside from this I am actuall yhaving difficulty understanding what you need, but hopefully this helps?
numberofgrids = input
i = 1 to numberofgrids
gridCount = gridCount + 1
'Loop Stuff
Case Select gridCount
Case is = 1
'logic
Case is = 2
'logic
Etc etc
End Select
If numberofgrids = gridCount Then
Exit For
End If
Next i
As a complete beginner to VBA Excel, I would like to be able to do the following:
I want to find the first value larger than 0 in a row, and then sum over the following 4 cells in the same row. So
Animal1 0 0 1 2 3 0 1
Animal2 3 3 0 1 4 2 0
Animal3 0 0 0 0 0 1 0
Results in
Animal1 7
Animal2 11
Animal3 1
Is this possible?
(Your problem description didn't match your examples. I interpreted the problem as one of summing the 4 elements in a row which begin with the first number which is greater than 0. If my interpretation is wrong -- the following code would need to be tweaked.)
You could do it with a user-defined function (i.e. a UDF -- a VBA function designed to be used as a spreadsheet function):
Function SumAfter(R As Range, n As Long) As Variant
'Sums the (at most) n elements beginning with the first occurence of
'a strictly positive number in the range R,
'which is assumed to be 1-dimensional.
'If all numbers are zero or negative -- returns a #VALUE! error
Dim i As Long, j As Long, m As Long
Dim total As Variant
m = R.Cells.Count
For i = 1 To m
If R.Cells(i).Value > 0 Then
For j = i To Application.Min(m, i + n - 1)
total = total + R.Cells(j)
Next j
SumAfter = total
Exit Function
End If
Next i
'error condition if you reach here
SumAfter = CVErr(xlErrValue)
End Function
If your sample data is in A1:H3 then putting the formula =SumAfter(B1:H1,4) in I1 and copying down will work as intended. Note that the code is slightly more general than your problem description. If you are going to use VBA, you might as well make your subs/functions as flexible as possible. Also note that if you are writing a UDF, it is a good idea to think of what type of error you want to return if the input violates expectations. See this for an excellent discussion (from Chip Pearson's site - which is an excellent resource for Excel VBA programmers).
ON EDIT: If you want the first cell greater than 0 added to the next 4 (for a total of 5 cells in the sum) then the function I gave works as is, but using =SumAfter(B1:H1,5) instead of =SumAfter(B1:H1,4).
This is the one of the variants of how you can achieve required result:
Sub test()
Dim cl As Range, cl2 As Range, k, Dic As Object, i%: i = 1
Set Dic = CreateObject("Scripting.Dictionary")
For Each cl In ActiveSheet.UsedRange.Columns(1).Cells
For Each cl2 In Range(Cells(cl.Row, 2), Cells(cl.Row, 8))
If cl2.Value2 > 0 Then
Dic.Add i, cl.Value2 & "|" & Application.Sum(Range(cl2, cl2.Offset(, 4)))
i = i + 1
Exit For
End If
Next cl2, cl
Workbooks.Add: i = 1
For Each k In Dic
Cells(i, "A").Value2 = Split(Dic(k), "|")(0)
Cells(i, "b").Value2 = CDec(Split(Dic(k), "|")(1))
i = i + 1
Next k
End Sub
Here is what I would use, I dont know any of the cell placement you have used so you will need to change that yourself.
Future reference this isnt a code writing site for you, if you are new to VBA i suggest doing simple stuff first, make a message box appear, use code to move to different cells, try a few if statments and/or loops. When your comftable with that start using varibles(Booleans, string , intergers and such) and you will see how far you can go. As i like to say , "if you can do it in excel, code can do it better"
If the code doesnt work or doesnt suit your needs then change it so it does, it worked for me when i used it but im not you nor do i have your spread sheet
paste it into your vba and use F8 to go through it step by step see how it works and if you want to use it.
Sub test()
[A1].Select ' assuming it starts in column A1
'loops till it reachs the end of the cells or till it hits a blank cell
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
'adds up the value of the cells going right and removes the previous cell to clean up
Do Until ActiveCell.Value = ""
x = x + ActiveCell.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).ClearContents
Loop
'goes back to the begining and ends tallyed up value
Selection.End(xlToLeft).Select
ActiveCell.Offset(0, 1).Value = x
'moves down one to next row
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I have a Excel matrix as below:
PID# T1 T2 T3 T4 T5 T6 T7
11 1 1
14 1 1 1
21 1 1
41 1 1 1 1
71 1
88 1 1 1
PID# is nothing but the processes, all the processes has been composed of multiple tasks. But it is not mandatory that all processes should use all the T1 - T5 tasks. In such a scenario is it possible to get the PID# which used maximum tasks. 1 used to indicate that a task has been used or not. here the PID# 41 and 88 used maximum tasks say it is 5. I need only the maximum used column count and any of the row# which used that number of columns.
NOTE
here i have used 1 to tell there is data,but in reality there are different types of data. I need to find out which row used maximum columns.But one thing if any cells for a row is blank and it is to the left,should be in the count. say for example --
<> 1 <> 1 gives the count as 4
<> <> 1 <> will give the count as 3
1 1 <> will give the count as 2 ' here I used <> used to represent the no values
EDIT
Option Explicit
Dim ArrayListTaskDetails : Set ArrayListTaskDetails = CreateObject("System.Collections.ArrayList")
Dim i,colcount
i=2
Do while i < = objExcel1.Application.WorksheetFunction.CountA(ob.Rows(1))
colcount=objExcel1.Application.WorksheetFunction.CountA(ob.Rows(i))
ArrayListTaskDetails.Add(colcount)
i=i+1
Loop
ArrayListTaskDetails.Sort()
i=ArrayListTaskDetails.Count
MsgBox("HighestColumnNumner:" & ArrayListTaskDetails(i-1))
Problem:
I can't count the blank columns for rows which don't have the contiguous value. Thus count is not produced by me correctly.
EDIT1
Here the problem is still i can't count the left blank cells if any,as those are also to be considered as used column,in which other rows can have values.Thus need to find out the the right most column which has been used by a row after which no columns has been used by any rows. Hope I am able to clear what I am looking for:
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objWB,ColCount
Dim ArrayListTaskDetails : Set ArrayListTaskDetails = CreateObject("System.Collections.ArrayList")
Set objExcel1 = CreateObject("Excel.Application")
strPathExcel1 = "D:\AravoVB\.xlsx"
Set objWB = objExcel1.Workbooks.open(strPathExcel1)
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Do Untill count > objExcel1.Application.WorksheetFunction.CountA(objSheet1.Rows(1))
Range = objSheet1.("count:count")
ColCount=objExcel1.Application.WorksheetFunction.CountIf(Range,<> "")
ArrayListTaskDetails.Add(ColCount)
Loop
ArrayListTaskDetails.Sort()
MsgBox(ArrayListTaskDetails(ArrayListTaskDetails.Count - 1))
Thanks,
Still not convinced why Vikas answer is not working for you. Try this code please. It highlights the last max value. Only flaw is that it doesn't track all the PID that has same max value. I could improve the code if you need that as well.
Code:
Option Explicit
Sub getRealUsedColumns()
Dim rngInput As Range
Dim arrInput As Variant, arrRowTotal As Variant
Dim i As Integer, j As Integer, counter As Integer, iTemp As Integer
Dim iPID As Integer, maxRowNum As Integer
arrInput = Application.WorksheetFunction.Transpose(Sheets(3).Range("B3:I8").Value2)
ReDim arrRowTotal(LBound(arrInput, 2) To UBound(arrInput, 2))
For i = LBound(arrInput, 2) To UBound(arrInput, 2)
counter = 0
For j = LBound(arrInput) + 1 To UBound(arrInput)
If arrInput(j, i) <> "" Or Not IsEmpty(arrInput(j, i)) Then
counter = counter + 1
End If
Next j
'-- most recent max value (if you have two of the same, this doens't catch)
'-- you need to save in a proper array to catch multiple PIDs with same max value
If iTemp <= counter Then
iTemp = counter
iPID = arrInput(1, i)
maxRowNum = i
End If
arrRowTotal(i) = counter
Next i
'-- Row total into the sheet output
Sheets(3).Range("J3").Resize(UBound(arrRowTotal)) = _
Application.WorksheetFunction.Transpose(arrRowTotal)
'-- highlight the max total row.
With Sheets(3).Range("B3").Offset(maxRowNum - 1, 0).Resize(1, UBound(arrInput, 1) + 1)
.Interior.Color = 200
End With
End Sub
Results:
Excel is very powerful in calculating Matrix. I would use the Excel Formula instead of Code in order to calculate it. I would add a column in the right, which would add the total number of tasks used by a process, as shown in the matrix below.
A B C D E F G
1 PID T1 T2 T3 T4 T5 Total
2 #11 1 1
3 #14 1 1 1 3
4 #21 1 1 1 1 1 5
5 #41 1 1 2
Then I will write two Array Formulas to calculate the maximum number of tasks used by a process and the name of that process.
Formula to calculate maximum tasks used in the example: =SUM(IF($G$2:$G$5=MAX($G$2:$G$5),G2:G5,0))
Formula to find the pricess which used the maximum tasks:
=OFFSET(A1,SUM(IF($G$2:$G$5=MAX($G$2:$G$5),ROW(G2:G5)-1,0)),0,1,1)
Please note that I had mentioned that I used Array formulas. In order to add array formula in Excel, you need to enter formula and then press "Ctrl+Shift+Enter" to make that formula an array formula.
Hope this helps.
Vikas B
-----------------EDIT-----------------------------------------------------
Adding the code here. I just used the sample, as show in matrix and produced the correct result.
Sub FindMax()
'assuming column 1 is the task ID and Row one has the headings.
Const LastColumn As Integer = 7 ' you can use xl end to get the last used column in the range
Const LastRow As Integer = 5
Dim rowCounter As Integer
Dim prevValue As Integer
Dim rngToTotal As Range
Dim sht As Worksheet
Dim maxRowName As String
Dim value As Integer
Dim maxValue As Integer
Set sht = ActiveSheet
For rowCounter = 2 To LastRow
Set rngToTotal = sht.Range(sht.Cells(rowCounter, 2), sht.Cells(rowCounter, LastColumn))
value = WorksheetFunction.Sum(rngToTotal)
If value > prevValue Then
maxRowName = sht.Cells(rowCounter, 1).value
maxValue = value
End If
prevValue = value
Next rowCounter
MsgBox "Process name " & maxRowName & " = " & maxValue
End Sub