I have these cells:
Strings in cells
I would like to return specific parts of these strings - the "...bar" and "also csatlakozas" or "hatso csatlakozas" - to other cells.
Try below code, this should get you started:
Sub ExtractMatchingCells()
'Define in which column data is located
col = 1
lastRow = Cells(Rows.Count, col).End(xlUp).Rows
For i = 1 To lastRow
' Extract cell value to cell to the right
If InStr(0, Cells(i, col), "bar (also csatlakozas)") > 0 Or InStr(0, Cells(i, col), "bar (hatso csatlakozas)") Then
Cells(i, col + 1) = Cells(i, col)
End If
Next
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
I have rows of data
Some rows are blank apart from Column C
If Column A is blank then I would like to concatenate Column C with column C from the row above - then delete the row. There could be situations where Column A has 2 or more blank rows, so that would require all those rows in Column C to be merged together
This is the code I used, but I keep getting a mismatch error - not sure where I am going wrong, but the error highlights the line with the offsets in
Sub Merge()
Dim rng As Range
Set ws = Worksheets("test") 'Change your sheet name
Set rng = ws.Range("A1:M5600")
With ws
For i = rng.Rows.Count To 1 Step -1
If .Cells(i, 1) = "" Then
.Cells(i, 3).Offset(-1) = .Cells(i, 3).Offset(-1) & .Cells(i, 3)
.Rows(i).EntireRow.Delete
End If
Next
End With
End Sub
Maybe my comment is not very clear, this is what I mean:
If .Cells(i, 1).Value = "" Then
.Cells(i, 3).Offset(-1).Value = .Cells(i, 3).Offset(-1).Value & ", " & .Cells(i, 3).Value
(I also added ", " for readability purposes)
Edit after comment
.Cells(i, 3).Offset(-1).Value = CStr(.Cells(i, 3).Offset(-1).Value) & ", " & CStr(.Cells(i, 3).Value)
Is that better?
I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
My data includes headers. In column C, the cells sometimes contain "/" or ",". The goal is to split these cells and insert a new row underneath with every sub-string.
INPUT
OUTPUT
With the code below I have been able to replace all "," with "/". Split the cell in column C by the "/" delimiter and paste underneath. I have not been able to copy and paste the contents of the row underneath with every element in the split function array. It also seems to be pasting the split values beginning in cell C2 every time.
Sub SuspenseReport()
Dim SearchCell As Variant
Dim i As Integer
Dim cell As Range
Application.ScreenUpdating = False
Set Rng = Application.Range("C2:C1000") '*Change Last Row Value Here
vLr = ActiveCell.SpecialCells(xlLastCell).Row
For Each cell In Rng
cell = Replace(cell, ",", "/")
If InStr(1, cell, "/") <> 0 Then
SearchCell = Split(cell, "/")
For i = 0 To UBound(SearchCell)
Cells(i + 2, 2).Value = SearchCell(i)
Next i
End If
Next cell
Application.ScreenUpdating = True
End Sub
When inserting or deleting rows always work from the bottom up. To retain the order of the split value, work from last to first.
Option Explicit
Sub splitSlash()
Dim tmp As Variant, i As Long, j As Long
With Worksheets("sheet1")
.Columns("C").Replace what:=Chr(44), replacement:=Chr(47), lookat:=xlPart
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
tmp = Split(.Cells(i, "C").Value2 & Chr(47), Chr(47))
For j = UBound(tmp) - 1 To LBound(tmp) + 1 Step -1
.Cells(i + 1, "A").EntireRow.Insert
.Cells(i + 1, "A") = .Cells(i, "A").Value2
.Cells(i + 1, "B") = .Cells(i, "B").Value2
.Cells(i + 1, "C") = tmp(j)
Next j
.Cells(i, "C") = tmp(j)
Next i
End With
End Sub
I have a column (B) that contains many cities. I want to search in every row of column (A). If it contains a value from column B this value should be written in column (C).
I made a code that searches a static value. I want this value to be the row of (column A).
Public Function searchColumn()
V_End_Of_Table = ActiveSheet.UsedRange.Rows.Count 'count the number of rows used'
Dim cell As Range
For Each cell In Range("A1:A" & V_End_Of_Table)
If InStr(1, cell.Value, "anfa", vbTextCompare) > 0 Then
Range("C" & cell.Row).Value = "anfa"
Else
Range("C" & cell.Row).Value = "No Match Found"
End If
Next 'move onto next cell'
End Function
Edit
Column A | Column B | Column C
------------+---------------+------------
casa anfa | omar | anfa
rabat hassan| hassan | hassan
casa maarouf| maarouf | maarouf
casa omar | anfa | omar
| sultan |
| driss |
Column C is the column that I want to create.
try this
For i = 1 To V_End_Of_Table 'loop for column A
For j = 1 To V_End_Of_Table 'loop for column B
If InStr(1, Cells(i, 1).Value, Cells(j, 2).Value) > 0 Then
Cells(i, 3).Value = Cells(j, 2).Value 'write found B value in c column
Exit For
Else
Cells(i, 3).Value = "no match found"
End If
If Cells(j + 1, 2).Value = "" Then
Exit For
End If
Next j
Next i
Maybe with a formula:
=IF(ISERROR(MATCH("*"&B1,A:A,0)),"",MID(A1,FIND(" ",A1)+1,LEN(A1)))
try this solution
Sub test()
Dim oCellSearch As Range, oCellSource As Range, KeySource, Key
Dim Source As Object: Set Source = CreateObject("Scripting.Dictionary")
Dim Search As Object: Set Search = CreateObject("Scripting.Dictionary")
'Grab the data from the WorkSheets into Dictionaries
n = Cells(Rows.Count, "B").End(xlUp).Row
For Each oCellSearch In ActiveSheet.Range("B1:B" & n)
If oCellSearch.Value <> "" Then
Search.Add oCellSearch.Row, oCellSearch.Value
End If
Next
n = Cells(Rows.Count, "A").End(xlUp).Row
For Each oCellSource In ActiveSheet.Range("A1:A" & n)
If oCellSource.Value <> "" Then
Source.Add oCellSource.Row, oCellSource.Value
End If
Next
'Match for contain
For Each Key In Search
For Each KeySource In Source
If UCase(Source(KeySource)) Like "*" & UCase(Search(Key)) & "*" Then
ActiveSheet.Cells(Key, "C").Value = Search(Key): Exit For
End If
Next
Next
End Sub