The following short program should cycle through all sheets within a workbook and compare the values in the cells from (C11:end) to the cell in column B for that row, and then repeat this for each row below it where there is data.
The code won't run due to an 'overflow' error, implying that the variable NumRows is too large for the integer type (I think?). However, whilst the NumRows and NumCols vary from sheet to sheet, there are always <100 in each case. Changing the type to 'Long' causes Excel to hang. I'm not sure why this is happening, C11 is always bounded on both its right and bottom side by data so the .End function shouldn't be generating massive numbers.
I'm very new to all this so if anyone could please explain or suggest edits I'd be very grateful.
Sub cond_format()
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Dim i As Integer
Dim j As Integer
Dim NumRows As Integer
Dim NumCols As Integer
NumRows = ws.Range("C11", ws.Range("C11").End(xlDown)).Rows.Count
NumCols = ws.Range("C11", ws.Range("C11").End(xlToRight)).Columns.Count
For i = 1 To NumRows
For j = 1 To NumCols
If Cells(10 + i, 2 + j).Value >= (Cells(i + 10, 2).Value) * 1.2 Then
Cells(10 + i, 2 + j).Interior.Color = 10092492
ElseIf Cells(10 + i, 2 + j).Value <= (Cells(i + 10, 2).Value) * 0.8 Then
Cells(10 + i, 2 + j).Interior.Color = 5263615
End If
Next
Next
Next ws
End Sub
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I have to create a Macro which lets me Concatenate two columns at a time in a given range. For example: In range C1:Z200, I want to concatenate Column C&D, E&F, G&H and so on. How do I do it. This is my current code which only concatenate first two columns..rest remains the same.
Set Range = ActiveSheet.Range("C1:Z100")
For Each c In Range
c.Select
ActiveCell.FormulaR1C1 = ActiveCell & " " & ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).Activate
Selection.Clear
ActiveCell.Offset(0, 2).Activate
Next c
Try this:
Sub Concat()
Dim i As Long, j As Long
For i = 1 To 100 'number of rows
j = 1 'reset column to 1
Do While j < 25 'max number of columns (until Column Y-Z)
j = j + 2 'start from third column (Column C)
Cells(i, j) = Cells(i, j) & " " & Cells(i, j + 1) 'concat
Cells(i, j + 1).ClearContents 'clear
Loop
Next i 'next row
End Sub
Try this:
Sub ConcatAltCellsInAltCols()
Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet11")
Dim iLC As Long: iLC = oW.Cells(1, oW.Columns.Count).End(xlToLeft).Column
Dim iLR As Long: iLR = oW.Cells(oW.Rows.Count, 3).End(xlUp).Row
Dim iC As Long
Dim iR As Long
For iR = 1 To iLR
For iC = 3 To iLC Step 2
oW.Cells(iR, iC).Value = oW.Cells(iR, iC) & oW.Cells(iR, iC + 1)
Next
Next
End Sub
Try this using a one based array for better Performance:
Code
Option Explicit
Sub Conc()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Concat") ' <== change "Concat" to your sheet name to avoid subscript error
Dim v ' variant
Dim lng As Long
Dim j As Integer ' corr.
' use one based array to get field data
v = ws.Range("C1:Z100") ' your OP range
For lng = 1 To UBound(v)
' concatenate columns C&D, E&F, G&H, ...
For j = 0 To 11
v(lng, j * 2 + 1) = v(lng, j * 2 + 1) & v(lng, j * 2 + 2)
Next j
Next lng
' write array values back (overwriting D, F, H,... with the same values)
ws.Range("C1:Z100") = v ' your OP range
End Sub
I have a dataset that is dynamic, meaning N number of rows and N number of columns (groups). The first screenshot is how the data looks with 3 groups, but as I said it could be N number of groups. There can also be N number of items.
Initial Data:
The second screenshot shows how the data should look. I need to write the item name for every score (numeric value in that row). So I have to transpose the data somehow. I need to loop through the columns, but don't know how divide the groups in the loop since they have the same column headers. Only the definition and group number are always unique.
This has to be done in VBA.
Final data after looping through rows and columns and "transposing":
Thanks
EDIT: Here's the code I've tried so far, which leaves spaces between the sets and only works for the first group.
Sub transposeData()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim i As Long
Dim lastCol As Long
Dim j As Long
Dim n As Integer
Dim y As Long
Dim tempVal As Integer
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
lastCol = ws.Cells(ws2.Rows.Count, 1).End(xlUp).Row
For i = 3 To lastRow Step 1
For y = 3 To lastRow Step 1
For j = 3 To lastCol Step 1
If ws.Cells(i, j) <> vbNullString Then
tempVal = ws.Cells(i, j).Value
ws2.Cells(y, 2) = ws.Cells(i, 2).Value
ws2.Cells(y, 3) = tempVal
ws2.Cells(y, "K") = ws.Cells(2, j).Value
End If
If tempVal <> 0 And tempVal - 1 Then
y = y + 1
End If
If j = 41 Then
i = i + 1
End If
tempVal = 0
y = y
Next j
Next y
Next i
End Sub
I took advantage of Excel's Transpose ability to get this code to work based on your sample data exactly as it is shown:
Sub Transpose()
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'Sheets("Sheet1")
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1") 'Sheets("Sheet2")
ws2.Range("A1:D1").Value = Array("Name", "Value", "Test", "Defintion")
With ws1
'how many groups are there so we know how many times to transpose
'we find this out by counting the number of times "Defintion" appears
Dim lDef As Long
lDef = Application.WorksheetFunction.CountIf(.Rows(2), "Definition")
'get last row where grouped data appears
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim l As Long
For l = 3 To lRow 'loop through items
Dim rDef As Range, sFirst As String
Set rDef = .Rows(2).Find("Definition") 'find first instance of "Definition"
sFirst = rDef.Address 'get address of first occurence so we can test if we reached it again
'list Name (aka Item) (for as many rows as needed defined by how many groups * 4 (1 for each test))
With ws2
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(4 * lDef).Value = ws1.Range("A" & l)
End With
Do
'transpose values
rDef.Offset(l - 2, 1).Resize(1, 4).Copy 'uses l-2 to offset for each row throughout the loop
With ws2
'paste values (test results)
.Range("B" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).PasteSpecial xlPasteValues, Transpose:=True
'load test cases
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).Value = Application.WorksheetFunction.Transpose(Array("A", "B", "C", "D"))
'load definitions
.Range("D" & .Rows.Count).End(xlUp).Offset(1).Resize(4, 1).Value = Application.WorksheetFunction.Transpose(rDef.Offset(1).Value)
End With
Set rDef = .Rows(2).FindNext(After:=rDef) 'find next definition
Loop Until rDef Is Nothing Or rDef.Address = sFirst
Next
End With
End Sub
Take a look at this macro and see what you think about it. I copied your sample set and was able to duplicate your desired results using nested for loops. Let me know if anything needs clarification.
Option Explicit
Sub customTransposing()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim startingRow As Integer
Dim startingColumn As Integer
Dim numberOfPoints As Integer
Dim numberOfEntries As Integer
Dim numberOfGroups As Integer
Dim outputRowOffset As Integer
' -------------------------------------------------------------------------------------------
' User Variables
' -------------------------------------------------------------------------------------------
startingRow = 3
startingColumn = 1
numberOfPoints = 4 ' The number of test points i.e. A B C D
numberOfEntries = 0
numberOfGroups = 3
outputRowOffset = 10
' -------------------------------------------------------------------------------------------
' Counts the number of entries in the first column
' this section could most likely be improved
Cells(startingRow, startingColumn).Select
Do Until IsEmpty(ActiveCell)
If Not IsEmpty(ActiveCell) Then
numberOfEntries = numberOfEntries + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
For j = 0 To numberOfEntries - 1
For k = 0 To numberOfGroups - 1
For i = 0 To numberOfPoints - 1
' first column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn).Value = Cells(startingRow + j, startingColumn)
' second column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 1).Value = Cells(startingRow + j, startingColumn + 2 + i + k * (numberOfGroups + 2))
' third column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 2).Value = Cells(startingRow - 1, startingColumn + 2 + i)
' fourth column
Cells(startingRow + numberOfEntries + (j * numberOfPoints * numberOfGroups) + outputRowOffset + i + k * numberOfPoints, startingColumn + 3).Value = Cells(startingRow + j, startingColumn + 1 + k * (numberOfGroups + 2))
Next i
Next k
Next j
End Sub
I have this table about 50,000 rows long that I would like Excel to go through and assign a number or letter.
Basically I am trying to group rows of data based on their sum being greater than 1,000,000.
If cell A in that row is less than 1,000,000 it will go to the next row and add up the previous cell A to the current one, and so on. This continues until the sum of all rows >= 1,000,000. When that happens, a number is "assigned" (as in entered at the end of the rows).
Sample data:
Here is my current "pseudo" code:
For x = 2 to lastrow
y = 1
If Range("A" & x).value < 1000000 Then
'I know something needs to be entered here but I don't know what
Do while balance < 1000000
sumbalance = Range("A" & x) + Range("A" & x + 1)
'Until sumbalance >= 1000000 Then Range("A" & x).Offset(0, 2).value = y
Else
Range("A" & x).offset(0, 2).value = y + 1 '(?)
Next x
Can someone point me the in the right direction?
With 50K rows, you will likely appreciate moving the values into a variant array for processing then returning them to the worksheet en masse.
Dim i As Long, rws As Long, dTTL As Double, v As Long, vVALs As Variant
With Worksheets("Sheet2")
vVALs = .Range(.Cells(2, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "B")).Value2
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
dTTL = dTTL + vVALs(v, 1): rws = rws + 1
If dTTL >= 10 ^ 6 Then
For i = v - rws + 1 To v
vVALs(i, 2) = rws
Next i
dTTL = 0: rws = 0
End If
Next v
.Cells(2, "A").Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
It isn't clear how you wanted to end the sequence if the last set of numbers do not reach the 1M mark.
I hope i am clear in my comments, let me know if the code does what you want.
Option Explicit
Sub balance()
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Double, y As Integer
Dim lastrow As Long
Dim sumbalance As Double
Dim Reached As Boolean
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") 'Change the name of the sheet to yours
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row 'Check the last Row
For x = 2 To lastrow
y = 1 ' Number 1 will be past in column C when sumblance >= 1'000'000
Reached = False
Do
If Range("A" & x).Value < 10 ^ 6 Then ' Value less than 1'000'000
If sumbalance = 0 Then 'Start the sum balance at 0
sumbalance = Range("A" & x)
Else
sumbalance = Range("A" & x) + sumbalance 'We add the previous amount to the new one
x = x + 1
End If
Else
Range("A" & x).Offset(0, 2).Value = y ' If the number is directly >= 1'000'000
Reached = True
End If
Loop Until sumbalance >= 10 ^ 6 Or x = lastrow Or Reached = True
Range("A" & x).Offset(0, 2).Value = y 'when the Sum Balance is >= 1'000'000 so 1 is paste in column c
sumbalance = 0 'Reinitialize the balance to 0
Next x
End Sub