I am trying to check preceding and succeeding cell values in a column and if the cell values match either preceding or succeeding then the corresponding blank cell will automatically get updated based on preceding or succeeding values. My current code only updates based on preceding value and also the blank cell evaluation criteria is not included. Can anyone solve this
Sub Update_Blank()
Dim sh As Worksheet
Dim y As Long
Set sh = Sheets("Combine")
For y = 4 To 22 'selected range'
If sh.Cells(y, "X") = sh.Cells(y - 1, "X") and sh.Cells(y, "V").Value Then 'compares values
in Column X'
sh.Cells(y, "V").Value = sh.Cells(y - 1, "V").Value 'copies values from above if values in
column X matches'
End If
Next y
End Sub
If you want to fill the blank in the "V" column based on the values of the "X" column :
Sub Update_Blank()
Dim sh As Worksheet
Dim y As Long
Set sh = Sheets("Combine")
For y = 4 To 22 'selected range'
If sh.Cells(y, "V") = "" Then 'if blank
If (sh.Cells(y, "X") = sh.Cells(y - 1, "X") And sh.Cells(y, "X").Value = sh.Cells(y + 1, "X")) Then 'compares values in Column X'
sh.Cells(y, "V").Value = sh.Cells(y - 1, "V").Value 'copies values from above if values in column X matches'
End If
End If
Next y
End Sub
Related
I would like populate the blue area with random numbers.
sum of C3 to R3 should be equal to B3 value: 124
also;
sum of C3 to C26 should be equal to C2 value: 705
I tried to achieve it with the following code:
(this code was originally posted here: Code by #Mech
Sub RandomNumbersArray()
' dim your variables. this tells vba what type of variable it is working with
Dim lRow As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
' find the last row in column b (2) in the above defined ws
lRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
' loop through rows 3 to last row
For i = 3 To lRow
' generate a random number between 0 and the row contents of column B (5)
ws.Cells(i, 3).Value = Int(Rnd() * (ws.Cells(i, 2).Value + 1))
' generate a random number between 0 and the difference between column B and colum C
ws.Cells(i, 4).Value = Int(Rnd() * (ws.Cells(i, 2).Value - ws.Cells(i, 3).Value))
' subtract the difference between column B and the sum of column C and column D
ws.Cells(i, 5).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value)
' subtract the difference between column B and the sum of column C and column D and column E
ws.Cells(i, 6).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value + ws.Cells(i, 5).Value)
' subtract the difference between column B and the sum of column C and column D and column E and column F
ws.Cells(i, 7).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value + ws.Cells(i, 5).Value + ws.Cells(i, 6).Value)
Next i
' sum column C (column 3) and place the value in C2
ws.Cells(2, 3).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 3), Cells(lRow, 3)))
' sum column D (column 4) and place the value in D2
ws.Cells(2, 4).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 4), Cells(lRow, 4)))
' sum column E (column 5) and place the value in E2
ws.Cells(2, 5).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 5), Cells(lRow, 5)))
' sum column F (column 6) and place the value in F2
ws.Cells(2, 6).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 6), Cells(lRow, 6)))
' sum column G (column 7) and place the value in F2
ws.Cells(2, 7).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 7), Cells(lRow, 7)))
End Sub
EDIT: Just to clarify, no negative numbers.
Here is something to try:
Set all cells to 0. Create a list of all cells (some kind of reference to each cell).
Now, randomly choose a cell from your list, and add 1 to that cell. The very first time, all cells will be 0, except for one, which will now be 1.
For this cell that you just incremented, add up the row and column and see if the sums have been reached. If either the row or the column sum has been reached, remove this cell reference from the list.
Repeat (randomly choose a cell from those remaining on the list) until the list is empty.
At each iteration you are randomly choosing one of the remaining cells in the reference list (not choosing from all the cells) and this list is getting smaller and smaller as column or row sums are reached.
It should be the case that random cells will increment, and if the columns and sums can in fact be calculated by values without logical inconsistencies, you should fairly quickly reach that point when the reference list falls empty.
I have a solution.
Answers so far have mostly been about finding values which are random, then fixing them to fit the totals.
I tried finding a calculated (non random) solution that fits the totals, then made a separate sub to randomize it. This way you can prevent the randomization from introducing negative values.
There are two procedures, This sub will call them both on the same Range.
Sub Call_Random_Array
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
Dim RangeToFill as Range: Set RangeToFill = ws.Range("C3:R26") 'Edit this line to select whatever range you need to fill randomly
'Proportionately fill the array to fit totals:
Call ProportionateFillArray(RangeToFill)
'Randomize it x times
For x = 1 to 10 'increase this number for more randomisation
Call RandomizeValues(RangeToFill)
Next
End Sub
Proportionately fill the array to fit totals:
Sub ProportionateFillArray(rngAddress As Range)
Dim ws As Worksheet: Set ws = rngAddress.Worksheet
'Horizontal and Vertical target values as ranges:
Dim hTarg As Range, vTarg As Range
Set hTarg = rngAddress.Rows(1).Offset(-1, 0)
Set vTarg = rngAddress.Columns(1).Offset(0, -1)
'Check the totals match
If Not WorksheetFunction.Sum(hTarg) = WorksheetFunction.Sum(vTarg) Then
'totals don't match
MsgBox "Change the targets so both the horizontal and vertical targets add up to the same number."
Exit Sub
End If
With rngAddress
'Now fill rows and columns with integers
Dim Row As Long, Col As Long
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
.Cells(Row, Col) = Int( _
hTarg.Cells(Col) * vTarg.Cells(Row) / WorksheetFunction.Sum(hTarg) _
)
Next
Next
'Correct rounding errors
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
If Row = .Rows.Count Then
'Last row, so this column must be corrected come what may
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Sum(.Columns(Col)) + hTarg.Cells(Col)
ElseIf Col = .Columns.Count Then
'Last column, so must be corrected come what may
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Sum(.Rows(Row)) + vTarg.Cells(Row)
ElseIf _
(WorksheetFunction.Sum(.Rows(Row)) - vTarg.Cells(Row)) * _
(WorksheetFunction.Sum(.Columns(Col)) - hTarg.Cells(Col)) > 0 Then
'both row and column are incorrect in the same direction
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Max( _
WorksheetFunction.Sum(.Rows(Row)) - vTarg.Cells(Row), _
WorksheetFunction.Sum(.Columns(Col)) - hTarg.Cells(Col))
End If
Next
Next
End With
End Sub
Randomize an array without changing row or column totals:
Sub RandomizeValues(rngAddress As Range)
Dim ws As Worksheet: Set ws = rngAddress.Worksheet
Dim rngIncrease(1 To 2) As Range, rngDecrease(1 To 2) As Range, lDiff As Long
With rngAddress
'Select two cells to increase at random
For a = 1 To 2
Set rngIncrease(a) = .Cells(RndIntegerBetween(1, .Rows.Count), RndIntegerBetween(1, .Columns.Count))
rngIncrease(a).Select
Next
'Corresponding cells to decrease to make totals the same:
Set rngDecrease(1) = ws.Cells(rngIncrease(1).Row, rngIncrease(2).Column)
Set rngDecrease(2) = ws.Cells(rngIncrease(2).Row, rngIncrease(1).Column)
'Set the value to increase/decrease by - can't be more than the smallest rngDecrease Value, to prevent negative values
If Not WorksheetFunction.Min(rngDecrease) > 1 Then
'Don't decrease a value below 1
Exit Sub
Else
lDiff = RndIntegerBetween(1, WorksheetFunction.Min(rngDecrease)-1)
End If
'Now apply the edits
For a = 1 To 2
rngIncrease(a) = rngIncrease(a) + lDiff
rngDecrease(a) = rngDecrease(a) - lDiff
Next
End With
End Sub
'The below is the Random Integer function, I also used it in my other answer
Function RndIntegerBetween(Min As Long, Max As Long) As Long
RndIntegerBetween = Int((Max - Min + 1) * Rnd + Min)
End Function
This code is for what you were trying to do, not exactly how you explained it though (see comments). If this is what you were looking for, then your explanation was a bit off, otherwise let me know what you did mean.
Sub RandomNumbersArray()
Dim lRow As Long, lColumn As Long, remainingValue As Long
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
lRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
lColumn = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
For i = 3 To lRow 'loop through the rows
remainingValue = ws.Cells(i, 2).Value2
For j = 3 To lColumn 'loop through all the columns per row
' generate a random number between 0 and the row contents of column B - previous column
If j = lColumn Then 'last cell can't be random unless you want to extend the columns until the sum in B-column is met
ws.Cells(i, j).Value2 = remainingValue
Else
ws.Cells(i, j).Value2 = Int((remainingValue + 1) * Rnd)
End If
remainingValue = remainingValue - ws.Cells(i, j).Value2
Next j
Next i
For j = 3 To lColumn 'loop through the columns to set the sum
ws.Cells(2, j).Value2 = Application.WorksheetFunction.Sum(Range(Cells(3, j), Cells(lRow, j)))
Next j
End Sub
I'm yet to get past the O-column with any value above 0 however
Goodevening,
with your help i can manage to multiply some elements on a right column with some other elements on a left column, but the elements on the left were seprated by blank cells.
What if there aren't blank space?
How can i do the condition in the cycle?
The previous code (with space) was this: (Thank you)
Sub test()
Dim x As Integer
Dim y As Integer
Range("A1").Select
x = 1
y = 1
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
If IsEmpty(Cells(x, "A")) = True Then
y = x + 1
End If
If IsEmpty(Cells(x, "A")) = False Then
Cells(x, "E").Value = Cells(x, "A").Value * Cells(y, "D").Value
End If
x = x + 1
ActiveCell.Offset(1, 0).Select
Loop
End Sub
This is the result i would like to achive: (so, the first number on column D will be multiplied for every number on the left Until the number on the column D change, and so goes on till the end)
Just a FYI, this could be done with a formula in E1:
=A1*LOOKUP(2,1/(D$1:D1<>""),D$1:D1)
Trying to loop two columns and put result into one column.
1) looping is incorrect (no hits = wrong)
2) printing puts result into two different columns ("O" +7 from H and "R" +7 from K).
Private Sub FindValueKH_JN()
'New column O (no 15)
'Find if value starting in column H (no8) is between 207100-208100
'AND if value starting in column K (no11) is between 12700-12729,
' then T2J in column O, else T2N in O
Range("O1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "T2 er Ja eller Nei"
Dim loopRange As Range
'From H to new column O is +7 columns
lastrow1 = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row
'From K to new column O is +4 columns
lastrow2 = ActiveSheet.Cells(Rows.Count, "K").End(xlUp).Row
'loop columns H and K
Set loopRange = Union(Range("H2:H" & lastrow1), Range("K2:K" & lastrow2))
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And _
Left(cell.Value, 5) >= 12700 And Left(cell.Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
End Sub
Your references are incorrect, and this is why you are not getting any hits. You want to check two separate columns for specific values, but instead are just looking in one single cell for both conditions:
For Each cell In loopRange will loop through every cell in your defined loopRange range, which contains both columns.
You'd have to change your code so it loops through just a single column instead, like the following
Dim loopRange As Range
lastrow = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row 'From H to new column O is +7 columns
Set loopRange = Range("H2:H" & lastrow1) 'loop columns H
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And Left(cell.Offset(, 3).Value, 5) >= 12700 And Left(cell.Offset(, 3).Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
In your If-statement, you are checking the content of a single cell and your If-statement can never be true. With your Union-statement, you will get a Range with all cells of Col H and all cells of Col K, and in the loop you are checking all cells that are either in H or in K.
So your If hits, for example, Cell H2 and you are checking if the content is > 207100 and in the same moment < 12729.
What you probably want is to loop over all cells if column H, check it's value together with the value of the cell in column K of the same row.
I assume your cells contain a string starting with a number but holds also some characters. I would advice that you write the values into intermediate variables, makes it much easier to debug. You are using the left-function which will give you the first 6 (resp. 5) characters. The result is still a string (even if it contains only digits), and you compare it to a number, and that's not a good idea because now VBA has to do some implicit conversions, and that may lead to unexpected results. You should use the Val-function to convert a string into a numeric value.
As already mentioned in the comments, never work implicit on the so called Active Worksheet. Specify explicitly the worksheet you want to work with.
One question: Why do you use the strange syntax for the Else-statement. The : means that you put a second statement into a line. It is much more readable to omit the : and put the next statement(s) into separate lines.
Dim loopRange As Range, cell As Range, lastrow As Long
With ThisWorkbook.Sheets(1)
lastrow = .Cells(Rows.Count, "H").End(xlUp).row
Set loopRange = .Range("H2:H" & lastrow)
End With
For Each cell In loopRange
Dim valH As Long, valK As Long
valH = Val(Left(cell.Value, 6))
valK = Val(Left(cell.Offset(0, 3).Value, 6))
If valH >= 207100 And valH <= 208100 And valK >= 12700 And valK <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else
cell.Offset(0, 7).Value = "T2N"
End If
Next cell
I have several sheets in a workbook where if there are multiples of a number in a list I need to move an adjacent column over 1. This adjacent column is being used in a formula in the sheet. I want the formula to reference the value in its new position.
This is the table before the code
This is the ideal result where all the ones and fives had their numbers moved over 1 column but the formula still references the cell.
I've written:
For i = 1 To WS_Count
sheet_name = ActiveWorkbook.Worksheets(i).Name
row_count = Worksheets(sheet_name).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
For x = 11 To row_count
cell = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 1)
If cell = "" Then GoTo NextIteration
If ActiveWorkbook.Worksheets(sheet_name).Cells(x - 1, 1) = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 1) Or ActiveWorkbook.Worksheets(sheet_name).Cells(x + 1, 1) = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 1) Then
ActiveWorkbook.Worksheets(sheet_name).Cells(x, 5) = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 4)
ActiveWorkbook.Worksheets(sheet_name).Cells(x, 4).ClearContents
End If
NextIteration:
Next x
Next i
The cut is not working properly over the multiple sheets. It doesn't properly move to the new sheet.
Is there a way to move a cell's value and the reference to the cell from the formula over multiple sheets?
You can Cut the values over:
Dim ws As Worksheet, i As Long, x As Long, row_count As Long, v
For i = 1 To WS_Count
Set ws = ActiveWorkbook.Worksheets(i)
row_count = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
For x = 11 To row_count
v = ws.Cells(x, 1).Value
If Len(v) > 0 Then
If ws.Cells(x - 1, 1) = v Or ws.Cells(x + 1, 1) = v Then
ws.Cells(x, 4).Cut ws.Cells(x, 5)
End If
End If
Next x
Next i
Why not copy the formula?
https://learn.microsoft.com/en-us/office/vba/api/excel.range.formula
The algorithm
for....
if ....
You can copy formula to the adjacent cell, then empty the cell
If you copy directly the formula from one cell to the another, the formula doesn't change
Basically I have 3 worksheets . From the first worksheet I get a value (rotid) , and by using the match function I try to find the value in the second worksheet , and copy the row associated with the value into worksheet 3 where y is the index of the row in sheet 2 which corresponds to the value (rotid). But sometimes a value is not found in worksheet 2 and the program crashes . How can I deal with this error ?
worksheet 1 is list,
worksheet 2 is rotmain2,
worksheet 3 is imdb
btw this is how my code looks like . Im not sure how to use codetags.
Sub combine_imdb_rot_data()
' y is the index of the row in rotmain2 which corresponds to rotid
Dim y As Variant
Sheets("imdbmain").Select
For i = 1 To 4415
' select sheet list and assign rotid for value of the cell in row i+1 and column 7
rotid = Sheets("list").Cells(i + 1, 7).Value
' if rotid is not empty,
If Len(rotid) > 0 Then
'look for a row that corresponds to the rotid in worksheet "rotmain2"
Sheets("rotmain2").Select
'x = Sheets("list").Cells(i + 1, 7).Row
y = WorksheetFunction.Match(rotid, Range("B1:B4218"), 0)
If IsNumeric(y) Then
' copy the information in the row
Range(Cells(y, 1), Cells(y, 13)).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
Else
' copy the information in the row
Range(A4220, M4220).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
End If
End If
Next
End Sub
I also tried with another method suggested by Remou.
Is this how the .find method works ? Im not sure but when I use it I get a Runtime error 13 type mismatch:
Sub combine_imdb_rot_data()
' y is the index of the row in rotmain2 which corresponds to rotid
Dim y As Variant
Sheets("imdbmain").Select
For i = 1 To 4415
' select sheet list and assign rotid for value of the cell in row i+1 and column 7
rotid = Sheets("list").Cells(i + 1, 7).Value
' if rotid is not empty,
If Len(rotid) > 0 Then
'look for a row that corresponds to the rotid in worksheet "rotmain2"
Sheets("rotmain2").Select
'x = Sheets("list").Cells(i + 1, 7).Row
Set y = Range("B1:B4218").Find(rotid)
If y Is Nothing Then
' copy the information in the row
'Range("1:4," & x & ":" & x).Copy
'Range("A&x"&:&"M&x").Copy
'Copy empty row
Range("A101:M101").Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Else
' copy the information in the row
'Range("1:4," & x & ":" & x).Copy
'Range("A&x"&:&"M&x").Copy
Range(Cells(y, 1), Cells(y, 13)).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
End If
End If
Next
End Sub
You could trap the error, or perhaps use Find:
rotid=5 ''Let us say
With Worksheets(1).Range("B1:B4218")
''Find returns a range object, so we use Set
Set y = .Find(rotid, LookIn:=xlValues, lookAt:=xlWhole)
If y Is Nothing Then
Debug.Print "Not found"
Else
''This will print a cell, $b$15, for example
Debug.Print y.Address
''This will print 5
Debug.Print y.Value
End If
End With
Futher information: http://msdn.microsoft.com/en-us/library/aa195730%28office.11%29.aspx
The first thing you may want to do is put On Error Resume Next at the top of your module. Give that a try first.