Counting file from a date range depending on date modified - excel

I have a file path in Column A and want to display the count of how many files are between a date range, and if there are any files I want to be able to have a comment on the cell showing the file names and dates.
I have a code that I've gotten help on, but when the code runs it counts all the files in the folder and the comment only appears on the last number in the column.
Sub CreateMouseoverList(Optional FileFilter As String, Optional LowDate As Date, Optional HighDate As Date)
Dim Cell As Range
Dim Ext As Variant
Dim File As Object
Dim FileCnt As Long
Dim Files As Object
Dim Folder As Variant
Dim Item As Variant
Dim List() As Variant
Dim MaxLen As Long
Dim ModDate As Date
Dim m As Long
Dim n As Long
Dim Note As Comment
Dim Text As String
If IsMissing(FileFilter) Then FileFilter = "*.*"
' // Is there is no LowDate then use 1.
If LowDate = 0 Then LowDate = 2
' // If there is no HighDate then use today's date.
If HighDate = 0 Then HighDate = Now()
With CreateObject("Shell.Application")
For Each Cell In Range("A1", Cells(Rows.count, "A").End(xlUp))
FileCnt = 0
ReDim List(1 To 1)
Set Note = Cell.Offset(0, 1).Comment
If Note Is Nothing Then Set Note = Cell.Offset(0, 1).AddComment
Note.Shape.TextFrame.Characters(1, Len(Note.Text)).Delete
Note.Shape.TextFrame.Characters.Font.FontStyle = "regular"
Set Folder = .Namespace(Cell.Value)
If Not Folder Is Nothing Then
Set Files = Folder.Items
For Each Ext In Split(FileFilter, ";")
Files.Filter 64, Ext
Text = vbLf & " " & Ext & " Files | " & vbLf
List(UBound(List)) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
Text = String(Len(Text), "-") & " | " & vbLf
List(UBound(List)) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
Note.Shape.TextFrame.Characters.Font.Name = "Courier New"
Note.Shape.TextFrame.AutoSize = True
For Each File In Files
ModDate = File.ModifyDate
If ModDate >= LowDate And HighDate <= HighDate Then
FileCnt = FileCnt + 1
Text = File.Name & " | " & ModDate & vbLf
List(n) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
If Len(Text) > MaxLen Then MaxLen = Len(Text)
End If
Next File
Next Ext
Cell.Offset(0, 1).Value = FileCnt
Else
Cell.Offset(0, 1).Value = "Folder not found."
End If
Next Cell
End With
For Each Item In List
m = Len(Item)
n = Note.Shape.TextFrame.Characters.count + 1
Item = Split(Item, "|")
If UBound(Item) > -1 Then
Text = Item(0) & String(MaxLen - m, 32) & Item(1)
Note.Shape.TextFrame.Characters(n, Len(Text)).Insert Text
End If
Next Item
End Sub
Sub TestIt()
Call CreateMouseoverList("*.txt;*.xls", "4/1/2019","6/10/2019")
End Sub
I would like to be able to count all the files that are between a date range and display what the files are as well as the count.

Related

Finding nested duplicates

I am trying to make a Bill of Material list from my CAD software(Creo), this is exported out as a text file and its almost working perferct. The problem is that the text file spits out all parts in model, and I would like to count up duplicates instead of list them out after each other i.e quanties larger then 1.
My code does this nicely if the duplicate is listed in the row above, however if its nested(sub assy) this does not work. In picture below 00151564.asm(level 2) should be listed as quantity=3 but the parts on level 3 should be listed as quantity=1
Below is the original textfile creo spitts out, groups and patterns makes extra unwanteded indents, and material is just sometimes given..
Here is my code:
Sub simen2(Optional myFile As String = "Z:\Prosjekt\33907\Equipment and
materials\Structure\treetool2.txt")
Dim text As String
Dim textline As String
Dim textlineTemp As String
Dim foo As String
Dim output As String
Dim parent As String
Dim grandma As String
Dim greatgrandma As String
Dim greatgreatgrandma As String
Dim partNumber As String
Dim quantity As Integer
Dim material As String
Dim wsOut As Worksheet
Dim i, k As Long
Dim level, levelOld, levelTemp, levelTempOld, subtractLevel As Integer
Dim duplicate As Boolean
Dim levelDictionary As Object
'Init variables
Set wsOut = ThisWorkbook.Worksheets("Output")
subtractLevel = 0
quantity = 1
duplicate = True
partNumberOld = ""
commonNameOld = ""
levelOld = 0
levelTemp = 0
levelTempOld = 0
materialOld = ""
textlineOld = ""
material = "NA"
materialOld = "NA"
text = wsOut.Cells(1, 1).Value
wsOut.Cells.ClearContents
wsOut.Cells(1, 1).Value = text
wsOut.Cells(1, 2).Value = Now
wsOut.Cells(1, 3).Value = myFile
Call write2ExcelHeader(wsOut)
Set levelDictionary = CreateObject("Scripting.Dictionary")
i = 0
k = 1
FileNum = FreeFile()
Open myFile For Input As #FileNum
Line Input #FileNum, foo
Line Input #FileNum, foo
Do Until EOF(FileNum)
k = k + 1
' read in
Line Input #FileNum, textline
' Get level, however group and pattern fuck things up
If InStr(10, textline, "<HTML>") > 0 Or InStr(textline, "Pattern") > 0 Or InStr(textline, "Group") > 0 Then
levelTemp = getLevel(textline)
If levelTemp < levelTempOld Then
subtractLevel = 0
End If
If InStr(textline, "Pattern") > 0 Or InStr(textline, "Group") > 0 Then
subtractLevel = subtractLevel + 1
k = 1
End If
End If
' Grab material
If InStr(textline, "Materials") > 0 Then
Line Input #FileNum, textline
material = Trim(Replace(textline, "<curr>", ""))
End If
'we need to find out if the line has number as first item, i.e trim away spaces, it prints out previous item here...
If InStr(10, textline, "<HTML>") > 0 Then
'textlineTemp = RemoveHTML(textline)
'textlineTemp = Replace(textlineTemp, "Ã", "Ø")
partNumber = getPartNumber(textline)
commonName = getCommonName(textline)
partType = getType(partNumber)
material = "NA"
' add part to dictionary, this is unique parts
If levelDictionary.exists(partNumber) Then
levelDictionary(partNumber) = levelDictionary(partNumber) + 1
Else
levelDictionary.Add partNumber, 1
End If
' Remove duplicates ......
If partNumberOld = partNumber And levelTempOld = levelTemp Then
duplicate = True
quantity = quantity + 1
Else
quantity = 1
duplicate = False
End If
' get family history
level = levelTemp - subtractLevel
LevelArray(level) = partNumber
'lets present result
If Not duplicate Then
If level > 1 Then
parent = LevelArray(level - 1)
Else
parent = "NA"
End If
If level > 2 Then
grandma = LevelArray(level - 2)
Else
grandma = "NA"
End If
If level > 3 Then
greatgrandma = LevelArray(level - 3)
Else
greatgrandma = "NA"
End If
If level > 4 Then
greatgreatgrandma = LevelArray(level - 4)
Else
greatgreatgrandma = "NA"
End If
If i > 0 Then
Call write2Excel(wsOut, i + 2, partNumberOld, commonNameOld, quantityOld, materialOld, levelOld, partTypeOld, parentOld, grandmaOld, greatgrandmaOld, greatgreatgrandmaOld)
End If
i = i + 1
End If
End If
'we always uses previous values for print out
partNumberOld = partNumber
commonNameOld = commonName
levelOld = level
levelTempOld = levelTemp
partTypeOld = partType
quantityOld = quantity
materialOld = material
textlineOld = textline
parentOld = parent
grandmaOld = grandma
greatgrandmaOld = greatgrandma
greatgreatgrandmaOld = greatgreatgrandma
Loop
Close #FileNum
Debug.Print "How many parts " & i
Call DeList(wsOut)
Call CreateList(wsOut, "FilterOutput")
Call totalBOM(levelDictionary)
End Sub
An alternative OO approach using a class module. Output is to a sheet named "Output2".
Update 1 - Added debugging log, creo.log in same folder as workbook.
Option Explicit
Sub ProcessTextFile()
Const TXTFILE = "treetool_Rextroth.txt" '"treetool20210503.txt"
Const MAX_LEVEL = 10
Dim tree() As clsItem, item As clsItem
Dim ruler() As Integer, level As Integer, rs
Dim FileNum As Integer, textline As String, text As String
Dim start_name As Integer, width_name As Integer, n As Long
Dim t0 As Single: t0 = Timer
ReDim tree(MAX_LEVEL)
ReDim ruler(MAX_LEVEL)
FileNum = FreeFile()
Open ThisWorkbook.Path & "\" & TXTFILE For Input As #FileNum
' use first header line to get common name column position
Line Input #FileNum, textline
start_name = InStr(1, textline, "PTC_COMMON_NAME")
width_name = InStr(1, textline, "PRO_MP_") - start_name
' skip
Line Input #FileNum, textline
' set start level and indent
Set tree(0) = New clsItem
tree(0).level = 0
tree(0).id = "NA"
level = 1
ruler(1) = 1
' open log file
Dim fso, ts
Set fso = CreateObject("Scripting.Filesystemobject")
Set ts = fso.createtextfile("creo.log")
' scan text file
n = 2
Do Until EOF(FileNum)
n = n + 1
Line Input #FileNum, textline
rs = ParseLine(textline, n, ts)
If rs(0) = "ASM" Or rs(0) = "PRT" Then
' determine level from indent
level = GetLevel(ruler, rs(2), level, ts)
' create new item
Set item = New clsItem
With item
.itemtype = rs(0)
.id = rs(1)
.name = Mid(textline, start_name, width_name)
.qu = 1
.level = level
.parent = tree(level - 1).id
.creo = n
End With
' build tree
Set tree(level) = item
tree(level - 1).addItem item
' groups or patterns
ElseIf rs(0) = "GRP" Or rs(0) = "PTN" Then
' increase ruler for current level by 2
ruler(level) = ruler(level) + 2
ts.writeline n & " " & rs(0) & " change ruler(" & level & ")=" & ruler(level)
' materials
ElseIf rs(0) = "MTL" Then
If item.itemtype = "PRT" Then
' get material from next line
n = n + 1
Line Input #FileNum, textline
item.material = Trim(Replace(textline, "<curr>", ""))
End If
End If
Loop
' output tree
Application.ScreenUpdating = False
With Sheets("Output2")
text = .Range("A1")
.Cells.ClearContents
.Cells.Clear
.Range("A1") = text
.Range("B1") = Now
.Range("C1") = TXTFILE
With .Range("A2:H2")
.Value2 = Array("Part No", "Common Name", _
"Qu.", "Material", "Level", "Type", "Parent", "Creo Lines")
.Interior.Color = RGB(255, 200, 0)
.Font.Bold = True
End With
' save objects to sheet
tree(0).SaveToWorksheet .Range("A3")
' prettify
.Range("C:C,E:E").HorizontalAlignment = xlCenter
.Columns("H:H").HorizontalAlignment = xlRight
.Columns("A:H").AutoFit
.ListObjects.add(xlSrcRange, .UsedRange.Offset(1), , xlYes).name = "Table2"
.ListObjects("Table2").TableStyle = "TableStyleLight1"
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
MsgBox Format(n, "#,###") & " lines parsed in " & _
Format(Timer - t0, "0.00") & " seconds"
End Sub
' determine level from indent using ruler
Function GetLevel(ByRef ruler, indent, level, ts) As Integer
Dim n As Integer
n = level ' current level
' is this an increase on previous
If indent > ruler(n) Then
ts.writeline "GetLevel before ruler(" & n & ")=" & ruler(n)
n = n + 1
Else
' find previous level
n = 0
Do
n = n + 1
Loop While indent > ruler(n)
End If
ruler(n) = indent ' update
ts.writeline "Level now " & n & " ruler(" & n & ")=" & indent
GetLevel = n
End Function
' determine linetype, partno, indent
Function ParseLine(s As String, n, ts) As Variant
Dim indent As Integer, partno As String
Dim tmp As String, linetype As String
indent = Len(s) - Len(LTrim(s)) ' no of spaces
If InStr(1, s, "<HTML>") Then
tmp = WorksheetFunction.Trim(s)
partno = Split(tmp, " ")(0)
linetype = Right(partno, 3)
ts.writeline vbCrLf & n & " INDENT=" & indent & " '" & s
ElseIf InStr(1, s, "Materials") Then
linetype = "MTL"
ElseIf InStr(1, s, "Group") Then
linetype = "GRP"
ElseIf InStr(1, s, "Pattern") Then
linetype = "PTN"
End If
ParseLine = Array(linetype, partno, indent)
End Function
class module clsItem
========================
Option Explicit
' this class represent a part or assembly
Public id As String ' partno
Public name As String ' common name
Public itemtype As String ' PRT or ASM
Public parent As String
Public level As Integer
Public qu As Integer
Public material As String
Public creo As String ' source line nos in Creo file
Public items As New Collection
' add items
Public Function addItem(obj As clsItem)
' check if exists, if so increment quantity
Dim item As clsItem, bExists As Boolean
For Each item In items
If item.id = obj.id Then
item.qu = item.qu + obj.qu
item.creo = item.creo & " " & obj.creo
bExists = True
Exit For
End If
Next
' does not exist so add new
If Not bExists Then items.add obj, obj.id
End Function
' save object and all children
Public Sub SaveToWorksheet(rng As Range)
Const SP = 5 ' no of spaces to indent at each level
Dim item As clsItem
If level > 0 Then
rng = Space(level * SP) & id
rng.Offset(0, 1) = name
rng.Offset(0, 2) = qu
rng.Offset(0, 3) = material
rng.Offset(0, 4) = level
rng.Offset(0, 5) = itemtype
rng.Offset(0, 6) = parent
rng.Offset(0, 7) = creo
Set rng = rng.Offset(1)
End If
' recurse
For Each item In Me.items
item.SaveToWorksheet rng
Next
End Sub
This scans the Output sheet and creates a new sheet called "No Duplicates". However, with the bugs in your data I suspect this won't work for more complex cases e.g. where an assembly appears in other assemblies at different levels.
Update 1 - dictionary at each level
Sub RemoveDuplicates()
Const START_ROW = 3 ' skip headers
Const COL_PARTNO = 1 ' A
Const COL_QU = 3 ' C
Const COL_LEVEL = 5 ' E
Const COL_TYPE = 6 ' F
Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet
Dim iLastRow As Long, i As Long, r As Long
Dim PartNo As String, isASM As Boolean
Dim dictLevel As Integer, level As Integer
' dictionary at each level
Dim dictASM(10) As Object, arQu As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets("Output")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ReDim arQu(iLastRow)
For i = 0 To 10
Set dictASM(i) = CreateObject("Scripting.Dictionary")
Next
r = START_ROW
dictLevel = 0
Do
PartNo = Trim(ws.Cells(r, COL_PARTNO))
isASM = Trim(ws.Cells(r, COL_TYPE) = "ASM")
arQu(r) = ws.Cells(r, COL_QU)
level = ws.Cells(r, COL_LEVEL)
If isASM Then
' is this a new assembly clear lower level dictionaries
If level < dictLevel Then
For i = dictLevel To UBound(dictASM)
Set dictASM(i) = CreateObject("Scripting.Dictionary")
Next
dictLevel = level
Else
If dictASM(dictLevel).exists(PartNo) Then
' duplicate assembly
' increment first occurence
i = dictASM(dictLevel)(PartNo)
arQu(i) = arQu(i) + arQu(r)
arQu(r) = 0
level = ws.Cells(r, COL_LEVEL)
' delete lower level items
Do While ws.Cells(r + 1, COL_LEVEL) > level
r = r + 1
arQu(r) = 0 ' delete later
Loop
Else
' first occurence
dictASM(dictLevel).add PartNo, r
End If
End If
End If
r = r + 1
Loop While r < iLastRow
' create new sheet without duplicates
Set wsNew = Sheets.add
wsNew.Name = "No Duplicates"
ws.Range("A2:G2").Copy wsNew.Range("A2") ' header
i = START_ROW
For r = START_ROW To iLastRow
If arQu(r) > 0 Then
ws.Cells(r, 1).Resize(1, 8).Copy wsNew.Cells(i, 1)
wsNew.Cells(i, COL_QU) = arQu(r)
i = i + 1
End If
Next
wsNew.Columns("A:G").AutoFit
MsgBox Format(iLastRow - 1, "#,###") & " rows scanned", vbInformation
End Sub

Excel VBA script to output TSV is giving leading and trailing double quotes, how can I remove them

Sub ExportDataTSV()
Dim BCS As Worksheet
Dim Ctrl As Worksheet
Dim ws As Worksheet
Dim FName As String
Dim insertValues As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set BCS = ThisWorkbook.Sheets(Sheet2.Name)
Set Ctrl = ThisWorkbook.Sheets(Sheet1.Name)
fileDate = Year(Now) & "_" & Month(Now) & "_" & Day(Now) & "_" & Format(Now, "hh")
#If Mac Then
NameFolder = "documents folder"
If Int(Val(Application.Version)) > 14 Then
'You run Mac Excel 2016
folder = _
MacScript("return POSIX path of (path to " & NameFolder & ") as string")
'Replace line needed for the special folders Home and documents
folder = _
Replace(SpecialFolder, "/Library/Containers/com.microsoft.Excel/Data", "")
Else
'You run Mac Excel 2011
folder = MacScript("return (path to " & NameFolder & ") as string")
End If
FName = folder & ":bcs_output.txt"
#Else
folder = Environ$("userprofile")
FName = folder & "\Documents\bcs_output_" & fileDate & ".txt"
#End If
If Ctrl.Range("D9") = "" Or Ctrl.Range("D10") = "" Then
MsgBox "Please enter the Scenario Year and Scenario you wish to save and click again", vbOKOnly
Exit Sub
End If
Ctrl.Range("D9").Copy
BCS.Range("AS2").PasteSpecial Paste:=xlPasteValues
Ctrl.Range("D10").Copy
BCS.Range("AT2").PasteSpecial Paste:=xlPasteValues
Call ClearFile(FName)
With BCS
.AutoFilter.ShowAllData
numrows = .Cells(.Rows.Count, 1).End(xlUp).Row
numcol = .Cells(2, Columns.Count).End(xlToLeft).Column
.Range("AS1").Value = "scenario_year"
.Range("AS2:AS" & numrows).FillDown
.Range("AT1").Value = "scenario"
.Range("AT2:AT" & numrows).FillDown
.Range("AU1").Value = "save_date"
.Range("AU2").Formula = "=NOW()"
.Range("AU2:AU" & numrows).FillDown
.Range("AU2:AU" & numrows).NumberFormat = "yyyy-mm-dd hh:mm"
For x = 2 To numrows
Set rng1 = .Range("A" & x & ":R" & x)
Set rng2 = .Range("AC" & x & ":AF" & x)
Set rng3 = .Range("AH" & x & ":AK" & x)
Set rng4 = .Range("AN" & x & ":AO" & x)
Set rng5 = .Range("AS" & x & ":AU" & x)
Set Data = Union(rng1, rng2, rng3, rng4, rng5)
insertValues = Join2D(ToArray(Data), Chr(9))
Call ConvertText(FName, insertValues)
Next x
End With
With BCS
.Activate
.Range("A1").Select
End With
Ctrl.Activate
Application.ScreenUpdating = True
MsgBox "Cluster Data saved to " & FName & ", please upload the file here: https://awsfinbi.corp.amazon.com/s/dcgs_abv/submit", vbOKOnly
Application.EnableEvents = True
End Sub
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1
Next c
Next col
Next ar
ToArray = arr
End Function
Public Function Join2D(ByVal vArray As Variant, Optional ByVal sWordDelim As String = " ", Optional ByVal sLineDelim As String = vbNewLine) As String
Dim i As Long, j As Long
Dim aReturn() As String
Dim aLine() As String
ReDim aReturn(LBound(vArray, 1) To UBound(vArray, 1))
ReDim aLine(LBound(vArray, 2) To UBound(vArray, 2))
For i = LBound(vArray, 1) To UBound(vArray, 1)
For j = LBound(vArray, 2) To UBound(vArray, 2)
'Put the current line into a 1d array
aLine(j) = vArray(i, j)
Next j
'Join the current line into a 1d array
aReturn(i) = Join(aLine, sWordDelim)
Next i
Join2D = Join(aReturn, sLineDelim)
End Function
Public Function ClearFile(myfile)
Open myfile For Output As #1: Close #1
End Function
Public Function ConvertText(myfile As String, strTxt As String)
Open myfile For Append As #1
Write #1, strTxt
Close #1
End Function
The above functions are what I have strung together from various SO post and googles. It works to a large degree, but when it creates the txt file with the tab delimiter it gives an output where in the text separator is a single quote. However, the entire line is wrapped in double quotes. So the output looks something like "'Field1'\t'Field2'\t'Field3'" . That is not a valid TSV format for loading into a database like Redshift due to the double quotes. I need the double quotes to not be in the file, can anyone identify why it is adding them? Is there a way to prevent it or a better way to create a tab delimited file output for loading to Redshift?
For further information it MUST be a txt with tab delimiter, I have no control over that requirement.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/writestatement
Unlike the Print # statement, the Write # statement inserts commas
between items and quotation marks around strings as they are written
to the file. You don't have to put explicit delimiters in the list.
Write # inserts a newline character, that is, a carriage
return-linefeed (Chr(13) + Chr(10) ), after it has written the final
character in outputlist to the file.
To not add quotes switch to Print:
Print #1, strTxt

How to extract numbers from string and if there are more than one, add them together?

Excel spreadsheet
I have a set of over 10,000 lines of text strings in column A (Input), and I need to get the number (in case there is only one) or a sum of both (in case there are two).
Code
Here is the VBA code I have:
Sub ExtractNumericStrings()
Dim rngTemp As Range
Dim strTemp As String
Dim currNumber1 As Currency
Dim currNumber2 As Currency
Dim lngTemp As Long
Dim lngPos As Long
Dim lngLastRow As Long
With ActiveSheet
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngTemp In .Cells(1, "A").Resize(lngLastRow, 1) ' Set Range to look at
strTemp = rngTemp.Value2 ' Get string value of each cell
lngTemp = Len(strTemp) 'Get length of string
currNumber1 = 0 ' Reset value
currNumber2 = 0 ' Reset value
' Get first number
currNumber1 = fncGetNumericValue(strTemp, 1) ' Strip out first number
' Get second number if exists
' First strip out first number
strTemp = Replace(strTemp, currNumber1, "")
If Len(strTemp) <> 0 Then
currNumber2 = fncGetNumericValue(strTemp, 1)
End If
' now paste to sheet
If currNumber1 <> 0 And currNumber2 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1 + currNumber2
rngTemp.Offset(0, 2).Value = "sum of the numbers"
ElseIf currNumber1 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1
End If
Next rngTemp
End With
Call MsgBox("Procedure Complete!", vbOKOnly + vbInformation, "Procedure Complete")
End Sub
Private Function fncGetNumericValue(strTemp As String, lngStart As Long) As Currency
Dim varTemp As Variant
Dim lngCount As Long
Dim lngTemp As Long
' Reset
lngCount = 1
lngTemp = 1
varTemp = ""
On Error Resume Next
If IsNumeric(Left(strTemp, lngCount)) Then
Do While IsNumeric(Left(strTemp, lngCount)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
Else
' First clear non-numerics from string
lngTemp = 1
Do While IsNumeric(Left(strTemp, 1)) = False
lngTemp = lngTemp + 1
strTemp = Mid(strTemp, 2, Len(strTemp) - 1)
If lngTemp > Len(strTemp) Then
Exit Do
End If
Loop
' Then extract second number if exists
If strTemp <> "" Then
Do While IsNumeric(Mid(strTemp, lngCount, 1)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
End If
End If
' Retrun Value
If IsNumeric(varTemp) Then
fncGetNumericValue = CCur(varTemp)
Else
fncGetNumericValue = 0
End If
End Function
Here is what I'm trying to do:
https://www.youtube.com/watch?v=EjHnJVxuWJA
I have very limited knowledge of VBA, so please excuse me if I ask any stupid question. Running this thing successfully will save me hips of time. thanks!
Something like this:
Private Sub extract_num()
Dim cell as Range
Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' replace Sheet1 with ur sheet name
Dim lr as Long: Set lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim values() As String
Dim i as Byte
Dim temp as Double
For Each cell in ws.Range("A2:A" & lr)
If Not isEmpty(cell) Then
values = Split(cell, " ")
For i = LBound(values) to UBound(values)
values(i) = Replace(values(i), ",", ".")
If isNumeric(values(i)) Then
temp = temp + values(i)
End If
Next i
cell.Offset(0, 2) = temp
temp = 0
End If
Next cell
End Function
This is presuming:
a) Individual words and numbers are always separated by space "123 abc 321"
b) Commas "," are used as an arithmetic floatpoint separator ##,##
Slightly different approach from Rawrplus
Option Explicit
Sub UpdateTotals()
Dim aRawValues As Variant
Dim iLRow&, iRow&, iArr&
Dim dTotal#
With ThisWorkbook.Worksheets("Sheet1") '<-- Change the sheet name to your sheet
iLRow = .Cells(Rows.Count, 1).End(xlUp).Row ' Get row count
For iRow = 1 To iLRow ' Loop through all rows in the sheet
aRawValues = Split(.Range("A" & iRow).Value, " ") ' Create and array of current cell value
For iArr = LBound(aRawValues) To UBound(aRawValues) ' Loop through all values in the array
dTotal = dTotal + ReturnDouble(Replace(aRawValues(iArr), ",", ".")) ' Add the returned double to total
Next
.Range("B" & iRow).Value = dTotal ' Set value in column B
dTotal = 0# ' Reset total
Next
End With
End Sub
Function ReturnDouble(ByVal sTextToConvert As String) As Double
Dim iCount%
Dim sNumbers$, sCurrChr$
sNumbers = ""
For iCount = 1 To Len(sTextToConvert)
sCurrChr = Mid(sTextToConvert, iCount, 1)
If IsNumeric(sCurrChr) Or sCurrChr = "." Then
sNumbers = sNumbers & sCurrChr
End If
Next
If Len(sNumbers) > 0 Then
ReturnDouble = CDbl(sNumbers)
Else
ReturnDouble = 0#
End If
End Function

Difficulty in finding end of row in VB Excel

I am reading in information from a .txt file, This text file has 2 row and 6 column; each element is separated by space or tab. I have the data to read all the strings but I find difficult in putting the data to the cells. How can I find end of first Row.
Text File:
$SUBCASE 1 1
$DISP 0 509 5 1 2
Below is the complete code, I'm getting only the first character string and rest not...
Private Sub PCH_Click()
Dim arTemp() As Variant
Dim lRet As String
Dim sVal As String
Dim Row As Long
Dim Col As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'Default method Uses Open Dialog To Show the Files
lRet = Application.GetOpenFilename("PCH files (*.pch), *.*")
'Reads the file into characters
sVal = OpenTextFileToString2(lRet)
Dim tmp As Variant
tmp = SplitMultiDelims(sVal, ",;$ ", True) ' Place the 2nd argument with the list of delimiter you need to use
Row = 0
For i = LBound(tmp, 1) To UBound(tmp, 1)
Row = Row + 1
Col = 1
While Not vbNewLine = ""
ws.Cells(Row, Col) = tmp(i) 'output on the first column
MsgBox (tmp(i))
Col = Col + 1
Wend
Next i
End Sub
Function OpenTextFileToString2(ByVal strFile As String) As String
' RB Smissaert - Author
Dim hFile As Long
hFile = FreeFile
Open strFile For Input As #hFile
OpenTextFileToString2 = Input$(LOF(hFile), hFile)
Close #hFile
End Function
Function SplitMultiDelims(ByRef Text As String, ByRef DelimChars As String, _
Optional ByVal IgnoreConsecutiveDelimiters As Boolean = False, _
Optional ByVal Limit As Long = -1) As String()
Dim ElemStart As Long, N As Long, M As Long, Elements As Long
Dim lDelims As Long, lText As Long
Dim Arr() As String
lText = Len(Text)
lDelims = Len(DelimChars)
If lDelims = 0 Or lText = 0 Or Limit = 1 Then
ReDim Arr(0 To 0)
Arr(0) = Text
SplitMultiDelims = Arr
Exit Function
End If
ReDim Arr(0 To IIf(Limit = -1, lText - 1, Limit))
Elements = 0: ElemStart = 1
For N = 1 To lText
If InStr(DelimChars, Mid(Text, N, 1)) Then
Arr(Elements) = Mid(Text, ElemStart, N - ElemStart)
If IgnoreConsecutiveDelimiters Then
If Len(Arr(Elements)) > 0 Then Elements = Elements + 1
Else
Elements = Elements + 1
End If
ElemStart = N + 1
If Elements + 1 = Limit Then Exit For
End If
Next N
'Get the last token terminated by the end of the string into the array
If ElemStart <= lText Then Arr(Elements) = Mid(Text, ElemStart)
'Since the end of string counts as the terminating delimiter, if the last character
'was also a delimiter, we treat the two as consecutive, and so ignore the last elemnent
If IgnoreConsecutiveDelimiters Then If Len(Arr(Elements)) = 0 Then Elements = Elements - 1
ReDim Preserve Arr(0 To Elements) 'Chop off unused array elements
SplitMultiDelims = Arr
End Function
You can read a file row by row with following code
Sub IOTest()
Dim fnum, i As Integer, j As Integer
Dim line As String
Dim lines As Variant
Dim regEx As Object
Set regEx = CreateObject("vbscript.regexp")
With regEx
.Pattern = "\s{1}" 'only one whitespace
.Global = True 'find all occurrences
End With
fnum = FreeFile()
Open ThisWorkbook.Path & "\IO_Test.txt" For Input As #fnum
Do Until EOF(fnum) 'until End of file
i = i + 1
Input #fnum, line 'load row into line
'First replace found sole whitespaces with ","
'Then split on the ","s
lines = Split(regEx.Replace(line, ","), ",")
For j = LBound(lines) To UBound(lines)
Cells(i, j + 1) = lines(j)
Next j
Loop
Close #fnum
End Sub
I tested this with the strings
"$SUBCASE" & vbTab & "1" & vbTab & vbTab & vbTab & vbTab & "1"
"$DISP" & vbTab & "0" & vbTab & "509" & vbTab & "5" & vbTab & "1" & vbTab & "2"
And it only works if you have one whitespace(eg. space, tab,...) separating the data. If you have more than one whitespace between the data it gets trickier. But if you can provide an example on how the data is separated I can take a look at it.
I hope it helps, let me know either way ;)

Excel 2007 VBA code to automate extracting and storing numeric values from a string with special characters

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

Resources