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
Related
I have a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
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.
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.
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
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