Looking for the VBA to produce this result in a column of a sheet:
1.000000
1.000001
1.000002
…
…
1.001000
1.001001
1.001002
It can be text or number.
Thanks.
Hopefully this is a good starting point:
Sub foo()
Dim lngCount As Long
With Sheet1
For lngCount = 1 To 1002
.Range("A" & lngCount).NumberFormat = "0.000000"
.Range("A" & lngCount).Value = 1 + ((lngCount - 1) / 1000000)
Next lngCount
End With
End Sub
This would be especially suitable for a function
Public Function replacechar(str As String, charnumber As Integer, replacewith As String) As String
Dim startstr As String, endstr As String
startstr = Left(str, charnumber-1)
endstr = Right(str, Len(str) - Len(startstr))
replacechar = startstr & replacewith & endstr
End Function
You can call this function in a regular Sub, for example
Sub repl()
Dim newstr As String, c As Range
With ThisWorkbook.Sheets(1)
For Each c In .Range("A1:A100")
If not c.Value = "" Or Len(c.Value) < 5 Then
newstr = replacechar(c.Value, 5, "1") 'replaces the 5th char with "1"
c.Value = newstr
End If
Next c
End With
End Sub
This can done using NumberFormat and a Formula. the .Value2 = .Value2 converts the formula to an actual value
' Update ActiveSheet with your destination sheet reference
' Update .Cells(1,1) with reference to your starting cell - This is A1
' Update Resize(xxx) with the number of cells you want populated
With ActiveSheet.Cells(1, 1).Resize(100)
.NumberFormat = "0.000000"
.Formula = "=1 + (row()" & IIf(.Cells(1).Row > 1, " - " & .Cells(1).Row, "") & ") / 1e6"
.Value2 = .Value2
End With
Related
Example
In Cell "A2" I have 2,4,5,7-9
How do I count them by using formula or coding with vba
and count them as 2 4 5 7 8 9 which sum up value to 6
and return value in Cell "B2"
Please, try the next function. It builds a virtual discontinuous range and count its cells:
Function countNumb(strNo As String) As Long
Dim arr, i As Long
arr = Split(Replace(Replace(strNo, " ", ""), "-", ":"), ",")
For i = 0 To UBound(arr)
If Not InStr(arr(i), ":") > 0 Then
arr(i) = arr(i) & ":" & arr(i)
End If
Next
countNumb = Intersect(Range(Join(arr, ",")), Range("A:A")).cells.count
Debug.Print Range(Join(arr, ",")).Address 'only to visually see the built range before intersection address...
End Function
It can also process a string as "2, 4,5,7 - 9"...
It can be tested using the next code:
Sub testCountNumbers()
Dim x As String: x = "2,4,5,7-9"
Debug.Print countNumb(x)
End Sub
With VBA,
Function AddNumbers(rngTarget As Range) As Long
Dim arrValues() As String
Dim lngValue As Long
Dim strValue As String
Dim lngMinimum As Long
Dim lngMaximum As Long
arrValues = Split(rngTarget.Text, ",")
For lngValue = LBound(arrValues) To UBound(arrValues)
strValue = arrValues(lngValue)
If InStr(strValue, "-") > 0 Then
lngMinimum = CLng(Left(strValue, InStr(strValue, "-") - 1))
lngMaximum = CLng(Replace(strValue, lngMinimum & "-", vbNullString))
AddNumbers = AddNumbers + ((lngMaximum - lngMinimum) + 1)
Else
AddNumbers = AddNumbers + 1
End If
Next lngValue
End Function
Assuming column XFD in the active sheet is empty, and that no integer within the string will ever exceed 2^20:
=SUM(COUNTIF(INDIRECT("XFD"&SUBSTITUTE(TEXTSPLIT(A2,","),"-",":XFD")),""))
For those without TEXTSPLIT:
=SUM(COUNTIF(INDIRECT(SUBSTITUTE(FILTERXML("<a><b>XFD"&SUBSTITUTE(A2,",","</b><b>XFD")&"</b></a>","//b"),"-",":XFD")),""))
My spreadsheet currently has a column C with rows of data that have this structure below:
123 - abc - xyz
I want my VBA code to remove all the data before the first - including the - so that the column C would look like this:
abc - xyz
My current code is removing both "-"
Sub TrimCell()
Dim i As String
Dim k As String
i = "-"
k = ""
Columns("C").Replace what:=i, replacement:=k, lookat:=xlPart,
MatchCase:=False
End Sub
The Excel function I have for this is =REPLACE(C1,1,FIND("-",C1),""). This works but I want something in VBA.
This will work on column C:
Sub my_sub()
Dim c As Range
For Each c In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("C:C"))
c = Trim(Mid(c, InStr(c, "-") + 1))
Next
End Sub
You want to find the location of the first "-"
location = instr(1, cells(iRow,3), "-", vbTextCompare)
Taking advantage of fact that instr only returns the first entry...
Then trim the cell to the right using that location
if location > 0 then
'Found a "-" within this cell
cells(iRow,3) = right(cells(iRow,3), len(cells(iRow,3)-location)
end if
iRows is obviously just my iterator over the rows in your data. Define it whatever way you want.
You could dot it in one go using Evaluate.
With Range("C1", Range("C" & Rows.Count).End(xlUp))
.Value = Evaluate("MID(" & .Address & ", FIND(""-"", " & .Address & ")+1, LEN(" & .Address & "))")
End With
Please, try the next function:
Function replaceFirstGroup(x As String) As String
Dim arr
arr = Split(x, " - ")
arr(0) = "###$"
replaceFirstGroup = Join(Filter(arr, "###$", False), " - ")
End Function
It can be called/tested in this way:
Sub testReplaceFirstGroup()
Dim x As String
x = "123 - abc - xyz"
MsgBox replaceFirstGroup(x)
End Sub
In order to process C:C column, using the above function, please use the next code. It should be extremely fast using an array, working in memory and dropping the processing result at once:
Sub ProcessCCColumn()
Dim sh As Worksheet, lastR As Long, arr, i As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
arr = sh.Range("C2:C" & lastR).value
For i = 1 To UBound(arr)
arr(i, 1) = replaceFirstGroup(CStr(arr(i, 1)))
Next i
sh.Range("C2").Resize(UBound(arr), 1).value = arr
End Sub
How do I convert the alpha part of an excel address "$C$2" to 3 and 2 so that I could re-use it in a cell object.
If it is "$E$4", then I need two separate values like 5 (for the letter E) and 4, so that I could reference that using the object - Cells(4,5)
Basically, I am trying to un-merge cells using this code below and that is where the need to get the numeral of the excel cell came about.
Sub UnMerge()
Dim i As Integer
Dim fromRange() As String
Dim toRange() As String
Dim temp() As String
ActiveSheet.UsedRange.MergeCells = False
fromRange() = Split(ActiveCell.Address, "$")
temp() = Split(Selection.Address, ":")
toRange() = Split(temp(1), "$")
For i = fromRange(2) To toRange(2)
If Cells(i, Range(temp(0)).Column) = "" Then
Cells(i, Range(temp(0)).Column) = Cells(i - 1, Range(temp(0)).Column).Value
End If
Next i
End Sub
Debug.Print Range("$E$4").Row & ", " & Range("A1").Column
changing and spliting strings to get to numbers is slow. Just use the selection.rows and selection.column:
Sub UnMerge()
Selection.MergeCells = False
With ActiveSheet
Dim i As Long
For i = Selection.Row To Selection.Rows.Count + Selection.Row - 1
If .Cells(i, Selection.Column) = "" Then
.Cells(i, Selection.Column) = .Cells(i - 1, Selection.Column).Value
End If
Next i
End With
End Sub
I have tried this code which works fine for a cell that only contain number:
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Range("A1") + 1
End Sub
How can I do something similar if the cell has text and a number. For example, I have "Apple 1" and I want to "increase" the cell text to "Apple 2" and next time I run the macro I want "Apple 3".
Here's another way you could solve this problem:
Sub IncreaseCellValue()
Dim value As Variant
'Add 1 to the existing cell value
If IsNumeric(Range("A1").value) Then
Range("A1").value = Range("A1") + 1
Else
value = Split(Range("A1").value, " ")
Range("A1").value = value(0) & " " & (CInt(value(1)) + 1)
End If
End Sub
It will cover the 2 cases you presented in your question but not every scenario you could throw at it.
Try using the following function
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Replace(Range("A1").Value2, CleanString(Range("A1")), vbNullString) & CInt(CleanString(Range("A1").Value2)) + 1
End Sub
Function CleanString(strIn As String) As String
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d]+"
CleanString = .Replace(strIn, vbNullString)
End With
End Function
please check:
Option Explicit
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Dim rg As Range
Set rg = Cells(Rows.Count, "A").End(xlUp)
Range("A1" & ":" & rg.Address).AutoFill Destination:=Range("A1" & ":" & rg.Offset(1, 0).Address), Type:=xlFillDefault
End Sub
Or you may try something like this...
Function GetNumber(ByVal rng As Range) As Long
Dim i As Long
For i = Len(rng.Value) To 1 Step -1
If IsNumeric(Mid(rng.Value, i, 1)) Then
GetNumber = GetNumber & Mid(rng.Value, i, 1)
Else
Exit For
End If
Next i
End Function
Sub IncrementNumber()
Dim num As Long
num = GetNumber(Range("A1"))
Range("A1").Value = Replace(Range("A1").Value, num, num + 1)
End Sub
I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v