Choose random number from an Excel range - excel

In the list bellow it's an Excel Range, I need to choose two numbers equals to 100 so in return I want to get (30 & 70) or (60 & 40). Can I do that dynamically
I use Excel but if you have any suggestion of other programs it would be fine.
A
30
60
70
40

here the code without verification of duplicated pairs
Sub test()
Dim x&, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
If oCell1.Value + oCell2.Value = 100 Then
Dic.Add x, "(" & oCell1.Value & " & " & oCell2.Value & ")"
x = x + 1
End If
Next
Next
For Each Key In Dic
Debug.Print Key, Dic(Key) 'output in immediate window all possible
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
here the code with verification of duplicated pairs
Sub test()
Dim x&, S$, S2$, check%, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
check = 0
If oCell1.Value + oCell2.Value = 100 Then
S = "(" & oCell1.Value & " & " & oCell2.Value & ")"
S2 = "(" & oCell2.Value & " & " & oCell1.Value & ")"
For Each Key In Dic
If Dic(Key) = S Or Dic(Key) = S2 Then
check = 1: Exit For
End If
Next
If check = 0 Then
Dic.Add x, S
Debug.Print x, Dic(x)
x = x + 1
End If
End If
Next
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result

With your data in A1 thru A4, try this macro:
Sub JustKeepTrying()
Dim N As Long, M As Long, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Do
N = wf.RandBetween(1, 4)
M = wf.RandBetween(1, 4)
If N <> M Then
If Cells(M, 1) + Cells(N, 1) = 100 Then
MsgBox Cells(M, 1).Address & vbTab & Cells(M, 1).Value & vbCrLf _
& Cells(N, 1).Address & vbTab & Cells(N, 1).Value
Exit Sub
End If
End If
Loop
End Sub

Assuming you have in range A1:a11 numbers from 0 to 100 step by 10 [0,10,20,...,90,100] you could use this logic (here, result is highlighted with blue color)
Set BaseRange = Range("A1:a11")
BaseRange.ClearFormats
'first number- rundomly find
With BaseRange.Cells(Int(Rnd() * BaseRange.Cells.Count) + 1)
.Interior.Color = vbBlue
FirstNo = .Value
End With
'second number find by difference- error handling required if there is no matching value for each number
BaseRange.Find(100 - FirstNo).Interior.Color = vbBlue

Related

Find duplicates put sequence for each one

Assume I have data in column (A) like the following:
Names
Yasser
Hany
Ahmed
Reda
Ahmed
Yasser
Reda
Yasser
Duplicates can be detected using such a code
Sub Find_Duplicates()
Dim e, x(), dic As Object, cel As Range, lr As Long, i As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each cel In Range("A1:A" & lr)
If Not .Exists(cel.Value) Then
.Item(cel.Value) = cel.Value & "^" & cel.Address(0, 0)
Else
.Item(cel.Value) = Split(.Item(cel.Value), "^")(0) & " | " & cel.Value & "^" & Split(.Item(cel.Value), "^")(1) & " | " & cel.Address(0, 0)
End If
Next cel
If .Count Then
ReDim x(1 To .Count, 1 To 2)
For Each e In .Keys
If InStr(.Item(e), "|") > 0 Then
i = i + 1
x(i, 1) = Split(.Item(e), "^")(0)
x(i, 2) = Split(.Item(e), "^")(1)
End If
Next e
End If
Columns("F:G").ClearContents
Range("F1:G1").Value = Array("Duplicate Entries", "Address")
If i > 0 Then Range("F2").Resize(i, 2).Value = x
End With
Application.ScreenUpdating = True
End Sub
The output would be in columns F & G like that
What I am trying to get is like that (in Column B)
If you decide on formulas instead, then you could use:
Formula in B2:
=IF(COUNTIF(A$2:A$9,A2)>1,"Duplicate"&MATCH(A2,UNIQUE(FILTER(A$2:A$9,COUNTIF(A$2:A$9,A$2:A$9)>1)),0),"")
Non-ExcelO365 users could use:
=IF(COUNTIF(A$2:A$9,A2)>1,IF(MATCH(A2,A$1:A$9,0)=ROW(),"Duplicate"&MAX(IFERROR(--MID(B$1:B1,10,99),0))+1,INDEX(B$1:B1,MATCH(A2,A$1:A$9,0))),"")
Be sure to accept the formula through CtrlShiftEnter
You could modify your subroutine like this:
Sub Find_Duplicates()
Dim e, x(), dic As Object, cel As Range, lr As Long, i As Long, j As Long, arr() As String
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each cel In Range("A1:A" & lr)
If Not .Exists(cel.Value) Then
.Item(cel.Value) = cel.Value & "^" & cel.Address(0, 0)
Else
.Item(cel.Value) = Split(.Item(cel.Value), "^")(0) & " | " & cel.Value & "^" & Split(.Item(cel.Value), "^")(1) & " | " & cel.Address(0, 0)
End If
Next cel
If .Count Then
ReDim x(1 To .Count, 1 To 2)
For Each e In .Keys
If InStr(.Item(e), "|") > 0 Then
i = i + 1
arr = Split(Split(.Item(e), "^")(1), "|")
For j = LBound(arr) To UBound(arr)
Set cel = Range(Trim(arr(j)))
Cells(cel.Row, cel.Column + 1).Value = "Duplicate" & CStr(i)
Next j
End If
Next e
End If
End With
Application.ScreenUpdating = True
End Sub
Here, the cell addresses are split from each item and into an array of strings. Each cell address is used to move one cell to the right and then write the duplicate number there.

Writing debug data to new table on new worksheet

I have a large table that I need to identify when the value in the column "Pass Num" changes.
So far I have this
Sub loopTableRowsInAColumnListObject()
Dim lo As ListObject
Dim lRow As Range
Set lo = Sheets("Sheet3").ListObjects(1)
Debug.Print "LISTOBJECT APPROACH - FOR EACH LOOP"
Debug.Print "-----------------------------------"
For Each lRow In lo.ListColumns("Pass Num").DataBodyRange.Rows
If lRow.Offset(0, 0).Value2 <> lRow.Offset(-1, 0).Value2 Then
Debug.Print lRow.Row & vbTab & lRow.Value2 & vbTab & lRow.Offset(0, -24) & vbTab & lRow.Offset(0, -22) & vbTab & lRow.Offset(0, -11)
End If
Next lRow
Debug.Print "-----------------------------------"
End Sub
This writes to the intermediate window the values I require but I would like to write these to a new table on a new worksheet so a can call them back in to manipulate the table.
Any help would be appreciated
I ended up with this
'''
Sub loopTableRowsInAColumnListObject()
Dim lo As ListObject
Dim lRow As Range
Dim arr() As Variant
Set lo = Sheets("Sheet3").ListObjects(1)
With lo.DataBodyRange
tRows = .Rows.Count
tCols = .Columns.Count
End With
Dim i As Long
Dim c As Long 'number of passes
c = 0
'Debug.Print lo.DataBodyRange.Cells(2, lo.ListColumns("Pass num").Index)
For i = 1 To tRows
If lo.DataBodyRange.Cells(i, lo.ListColumns("Pass num").Index) <> lo.DataBodyRange.Cells(i - 1, lo.ListColumns("Pass num").Index) Then
c = c + 1
'Debug.Print lo.DataBodyRange.Cells(i, lo.ListColumns("Pass num").Index) & vbTab & c & vbTab & i
End If
Next i
' reDeclare an array to hold marks for c
ReDim arr(c, 2)
c = 0
For i = 1 To tRows
If lo.DataBodyRange.Cells(i, lo.ListColumns("Pass num").Index) <> lo.DataBodyRange.Cells(i - 1, lo.ListColumns("Pass num").Index) Then
c = c + 1
''Debug.Print lo.DataBodyRange.Cells(i, lo.ListColumns("Pass num").Index) & vbTab & c & vbTab & i
arr(x, 0) = c
arr(x, 1) = i
x = x + 1
End If
Next i
' Print results from the array to the Immediate Window
Debug.Print "results"
For x = LBound(arr) To UBound(arr)
Debug.Print arr(x, 0) & vbTab & arr(x, 1)
Next x
End Sub
'''
It looks through a column in a table "lo".
the counter "c" is for every time the "Pass Num" changes.
Counter "i" is the row number that that change happens.
These are placed in an array "arr"

concatenate vba excel keep format

I am building on some code, partly cut and paste from other posts. I need to concatenate with a VBA code keeping the format and running through rows to output in last cell in each row. (Can't paste image) so hope description is clear:
In A1:D1 values are RED,BLUE,GREEN
In A2:D2 Values are YELLOW,PURPLE,ORANGE
OUTPUT IN E1 should concatenate these values, keeping font colour. Each value should have "ALT ENTR" to give line break.
Next row should be displayed in E2, and so on
'************************************************************************************
Sub test()
Dim rng As Range: Set rng = Application.Range("a1:c1") 'Not yet looping
Dim row As Range
For Each row In rng.Rows
'Debug.Print col.Column
Call concatenate_cells_formats(Cells(1, 4), rng) 'Not yet looping
Next row
End Sub
Sub concatenate_cells_formats(cell As Range, source As Range)
'Anon
Dim c As Range
Dim i As Integer
i = 1
With cell
.Value = vbNullString
.ClearFormats
For Each c In source
.Value = .Value & " " & Trim(c)
Next c
.Value = Trim(.Value)
For Each c In source
With .Characters(Start:=i, Length:=Len(Trim(c))).Font
.Name = c.Font.Name
.FontStyle = c.Font.FontStyle
.Size = c.Font.Size
.Strikethrough = c.Font.Strikethrough
.Superscript = c.Font.Superscript
.Subscript = c.Font.Subscript
.OutlineFont = c.Font.OutlineFont
.Shadow = c.Font.Shadow
.Underline = c.Font.Underline
.ColorIndex = c.Font.ColorIndex
End With
.Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
i = i + Len(Trim(c)) + 1
Next c
End With
End Sub
'*****************************************************************************
Option Explicit
Sub concColour()
Dim i As Long, j As Long, s As Long, l As Long, clr As Long, vals As Variant
With Worksheets("sheet4")
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
vals = Application.Transpose(Application.Transpose(Intersect(.Range("A:D"), .Rows(i)).Value2))
.Cells(i, "E") = Join(vals, vbLf)
s = 1
For j = LBound(vals) To UBound(vals)
l = Len(vals(j))
clr = .Cells(i, "A").Offset(0, j - 1).Font.Color
With .Cells(i, "E").Characters(Start:=s, Length:=l).Font
.Color = clr
End With
s = s + l + 1
Next j
.Cells(i, "E").Font.Size = 4
Next i
End With
End Sub
enter image description here
I think you require something like this. Change source font and formats as per your requirement.
Sub Adding_T()
Dim lena As Integer
Dim lenc As Integer
Dim lend As Integer
Dim lene As Integer
Dim LastRow As Long
Dim nrow As Long
With Worksheets("Sheet2") 'Change sheet as per your requirement
LastRow = .Cells(.Rows.Count, "A").End(xlUp).row
For nrow = 1 To LastRow
.Range("E" & nrow) = .Range("A" & nrow).Value2 & Chr(13) & Chr(10) & .Range("B" & nrow).Value2 & _
Chr(13) & Chr(10) & .Range("C" & nrow).Value2 & Chr(13) & Chr(10) & .Range("D" & nrow).Value2
lena = Len(.Range("A" & nrow).Value2)
lenc = lena + 2 + Len(.Range("B" & nrow).Value2)
lend = lenc + 2 + Len(.Range("C" & nrow).Value2)
lene = lend + 2 + Len(.Range("D" & nrow).Value2)
For i = 1 To lena
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("A" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lena + 2 To lenc
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("B" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lenc + 2 To lend
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("C" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lend + 2 To lene
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("D" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
Next
End With
End Sub
Snapshot of trial:
EDIT: OP Preferred code does not permit looping through the Range. Amended his Sub Test() to allow looping through the range.
Sub Test2()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = ThisWorkbook.ActiveSheet
Dim rng As Range
Dim row As Range
Dim rw As Long
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).row
rw = 1
For rw = 1 To LastRow
Set rng = ws.Range("A" & rw & ":C" & rw)
Call concatenate_cells_formats(Cells(rw, 4), rng)
Next
End Sub
Results are as per snapshot appended here.

Excel VBA Code to Generate Sequential number with a Prefix

I have a small issue with my code. The code is below.
Private Sub CommandButton1_Click()
Dim Rng As Range, Dn As Range, n As Long
Dim pType As String
Dim oMax As Long
Set Rng = Range(Range("E1"), Range("E" & Rows.Count).End(xlUp))
Const StartNum = 1
pType = Me.TextBox1.Value
if pType = vbNullString Then MsgBox "Please Select Option from Combo Box": Exit Sub
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Left(Dn.Value, 1) = pType Then
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Mid(Dn, 2)
oMax = Application.Max(.Item(Dn.Value), Mid(Dn, 2))
Else
MsgBox "Number Exists:-" & Dn.Value
End If
End If
Next
If .Count = 0 Then
Range("E" & Rng.Count + 1) = pType & StartNum
Else
Range("E" & Rng.Count + 1) = pType & oMax + 1
End If
End With
End Sub
This code starts generating number from the 2nd row while i want the starting row should be 5. i tried to change the range value from E1 to E5 but it didn't work.
Kindly review and suggest the modification.
Thanks.
You just have to change the below line
Range("E" & Rng.Count + 1) = pType & StartNum
to
Range("E" & Rng.Count + 4) = pType & StartNum

concatenate cells when there are duplicates without using Transpose

I am using the following code - thanks #bonCodigo
Sub groupConcat()
Dim dc As Object
Dim inputArray As Variant
Dim i As Integer
Set dc = CreateObject("Scripting.Dictionary")
inputArray = WorksheetFunction.Transpose(Sheets(1).Range("A2:B7").Value)
'-- assuming you only have two columns - otherwise you need two loops
For i = LBound(inputArray, 2) To UBound(inputArray, 2)
If Not dc.Exists(inputArray(1, i)) Then
dc.Add inputArray(1, i), inputArray(2, i)
Else
dc.Item(inputArray(1, i)) = dc.Item(inputArray(1, i)) _
& "; " & inputArray(2, i)
End If
Next i
'--output into sheet
Sheets(1).Range("D2").Resize(UBound(dc.keys) + 1) = _
Application.Transpose(dc.keys)
Sheets(1).Range("E2").Resize(UBound(dc.items) + 1) = _
Application.Transpose(dc.items)
Set dc = Nothing
End Sub
A very elegant solution. Unfortunately, I am running into the limitation of using Transpose method. I have long strings that I would like to concatenate using the above code.
Any help will be appreciated.
Regards
This also uses a variant array but without the `Transpose`. It will ignore blank values to boot.
It runs by column, then by row
Sub Bagshaw()
Dim allPosts As Variant
Dim allPosts2 As Variant
Dim lngRow As Long
Dim lngCol As Long
Dim lngCnt As Long
Dim objDic As Object
Set objDic = CreateObject("Scripting.Dictionary")
allPosts = Range("A2:B5000").Value2
ReDim allPosts2(1 To UBound(allPosts, 1) * UBound(allPosts, 2), 1 To 1)
For lngCol = 1 To UBound(allPosts, 2)
For lngRow = 1 To UBound(allPosts, 1)
If Not objDic.exists(allPosts(lngRow, lngCol)) Then
If Len(allPosts(lngRow, lngCol)) > 0 Then
objDic.Add allPosts(lngRow, lngCol), 1
lngCnt = lngCnt + 1
allPosts2(lngCnt, 1) = allPosts(lngRow, lngCol)
End If
End If
Next
Next
Range("D2").Resize(UBound(allPosts2, 1)).Value2 = allPosts2
End Sub
Sub groupConcat()
Dim r As Range
Dim ro As Range
Dim myr As Range
Dim vcompt As Integer
vcompt = 0
Set ro = Range(Range("A2"), Range("A2").End(xlDown))
For i = Range("A2").Row To Range("A2").End(xlDown).Row
Debug.Print Range("A" & i).Address
Set myr = ro.Find(what:=Range("A" & i).Value, after:=Range("A2").End(xlDown), Lookat:=xlWhole, SearchDirection:=xlNext)
If myr Is Nothing Or myr.Address = Range("A" & i).Address Then
mystr = Range("A" & i).Offset(0, 1).Value
Set r = Range(Range("A" & i), Range("A2").End(xlDown))
Set myr = r.Find(what:=Range("A" & i).Value, Lookat:=xlWhole, SearchDirection:=xlNext)
If Not myr Is Nothing And r.Address <> Range("A2").End(xlDown).Address Then
Do While myr.Address <> Range("A" & i).Address
Debug.Print "r: " & r.Address
Debug.Print "myr: " & myr.Address
mystr = mystr & "; " & myr.Offset(0, 1).Value
Set myr = r.FindNext(myr)
Loop
End If
Range("D" & 2 + vcompt).Value = Range("A" & i).Value
Range("D" & 2 + vcompt).Offset(0, 1).Value = mystr
vcompt = vcompt + 1
End If
Next i
End Sub

Resources