My logic/code is pretty simple count rows from a SQL table, store this value to a Registry Key. If the value read from the SQL query is greater than the value of the RegKey, update the value of the RegKey with the query result, and likewise, save the value to a log file. If, the value of the SQL query is equal to the RegKey value, then do not store the result to the RegKey, but write 0 to the log file.
I run this code, and it seems it does not like my IF statements/operators. Testing this, it only seems to work if I set the operation "tempSQLCount(0,0) < strRegKeyVal " or "tempSQLCount(0,0) <> strRegKeyVal". In my scenario, the SQLCounter will never be less than, only greater than, or equal.
strRegKeyVal = readfromRegistry("HKEY_LOCAL_MACHINE\SOFTWARE\SQLCounter1", "ha")
'Dim intRegKeyVal = CInt(strRegKeyVal)
If tempSQLCount(0,0) > strRegKeyVal Then
'update row counter value to regKey
strValueName = "SQLCounter1"
objRegistry.CreateKey HKEY_LOCAL_MACHINE,strKeyPath
objRegistry.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,tempSQLCount(0,0)
Set objFSO=CreateObject("Scripting.FileSystemObject")
'write to log
outFile="C:\Logs\some.log"
Set objFile = objFSO.CreateTextFile(outFile,True)
objFile.Write tempSQLCount(0,0) & vbCrLf
objFile.Close
End If
If tempSQLCount(0,0) = strRegKeyVal Then
'update row counter value to regKey
Set objFSO=CreateObject("Scripting.FileSystemObject")
'write to log
outFile="C:\Logs\some.log"
Set objFile = objFSO.CreateTextFile(outFile,True)
objFile.Write 0 & vbCrLf
objFile.Close
End If
Get your logic straight and convert your numbers to the correct type. (This is mostly what the commenters suggested, but comments are hard to read for code improvements):
dim strRegKeyVal, sqlCountToReport, sqlCount
' both values are converted to Int
strRegKeyVal = cInt(readfromRegistry("HKEY_LOCAL_MACHINE\SOFTWARE\SQLCounter1", "ha"))
sqlCount = cInt(tempSQLCount(0,0))
' Conditional registry write part
If sqlCount > strRegKeyVal Then
'update row counter value to regKey
strValueName = "SQLCounter1"
objRegistry.CreateKey HKEY_LOCAL_MACHINE,strKeyPath
objRegistry.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName, sqlCount
sqlCountToReport = sqlCount
else
sqlCountToReport = 0
End If
' Write to log part
Set objFSO=CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("C:\Logs\some.log", True)
objFile.Write sqlCountToReport & vbCrLf
objFile.Close
Your script consist of two parts: the registry update part and the log write part. Splitting it in two tasks is easier to debug.
The flow is a little bit different; this also covers the case if cInt(tempSQLCount(0,0)) < strRegKeyVal, but that was a case that shouldn't happen anyways.
Related
I want to make a data validation list from text only in a Range of cells.
I searched for formula but I found nothing so I decided to make my own function but its not working.
I tried those codes:
Code 1:
Function ListFromRange(rng As Range) As Range
Dim cl As Range
Dim entry As Range
For Each cl In rng
If Not IsNumeric(cl.Value) Or cl.Value = "" Then
If entry Is Nothing Then
Set entry = cl
Else
Set entry = Union(entry, cl)
End If
End If
Next
Set ListFromRange = entry
End Function
Code 2:
Function ListFromRange2(rng As Range) As Variant
Dim cl As Range
Dim i As Integer
Dim entry() As String
ReDim entry(rng.Count)
For Each cl In rng
If Not IsNumeric(cl.Value) Or cl.Value = "" Then
entry(i) = cl.Value
i = i + 1
End If
Next
ListFromRange2 = entry
End Function
The second code is working but when I use with a defined name and use that defined name for data validation list its tells me that there is an error in the validation list source but when I use this function with index its returning the desired result.
Also some images to explain more:
I want to make a list from cells that contains a text and apply it here:
But without the number values.
The problem is that the resultant range is multiple columns and cannot be used as the source for a Data Validation List. If you cannot change the design of the table of options so that it is just one column, you need to find another way to set up the Validation List.
Here is a solution using VBA. I put this in a sub that can be run on demand as a macro, but you might drop it into a worksheet event that triggers when data on the sheet changes or some other event.
This will only create the validation list as far down as there is data in Column A. You'll probably want to carry it down further than this, or as mentioned, put this into a worksheet event so that it updates the Validation list as new rows are added.
I set up my sheets as follows, but you can also download my example here.
Option Explicit
Sub Create_Validation_List()
Dim rngList As Range, cl As Range
Dim rngValidationList As Range
Dim strList As String
Set rngList = Worksheets("BasicPrice").Range("A2:F3")
strList = ""
For Each cl In rngList
If Not IsNumeric(cl.Value) And Not cl.Value = "" Then strList = strList & "," & cl.Value 'Add to our Validation List
Next cl
strList = Mid(strList, 2) 'Chop off leading comma
'Apply Data Validation to this Range (starting at cell C2 and ending at the last row with data in column A)
Set rngValidationList = Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
Application.EnableEvents = False
With rngValidationList.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strList 'Pass in Validation List created above
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Application.EnableEvents = True
End Sub
Let me know if you have any questions.
I am writing a macro and the macro works fine, but I am trying to add some error handling to it so others are using it and an error occurs they are able to figure out what happened. The last problem I am having is I am using the Application.GetOpenFilename to open multiple files with multiselect = True. I am using a regex to match the file name and if the wrong file name is chosen then it displays an error message. If multiselect = False then I get no errors, but when it is equal to True I get a Type Mismatch error. I can only assume this is because when mutliselect = True the file is an array which the regex cannot handle. Is there a solution to this or can anyone point me to a better solution to handle the error. I have attached the VBA script as well.
Sub DataImport_Loop()
Dim nom As String
Dim wb As Excel.Workbook
Dim i, j, k, m, n, file As Variant
Dim strPattern As String: strPattern = "Strain End Point [0-9] - FEA Loop - Loading - (Timed)" 'File Pattern
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
'Turns Screen Updating and Alert Displays off
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nom = ActiveWorkbook.Name
'takes user straight into necessary folder
If CurDir() <> CurDir("J:") Then
ChDrive "J:"
ChDir "J:FEA Material Data"
End If
'Number of specimens tested
For i = 1 To 5
'Allows user to select multiple files to open
file = Application.GetOpenFilename( _
FileFilter:="Text Files (*.csv), *.csv", _
MultiSelect:=True)
'If no file selected, stop data import and display error message
If Not IsArray(file) Then
MsgBox ("You only imported " & (i - 1) & " Specimens.")
Exit Sub
'Sets patteren to check if correct file
With regex
.Pattern = strPattern
End With
'Checks set pattern, displays error message if not correct file
If regex.Test(file) = False Then
MsgBox ("Select Loading Only")
Exit Sub
End If
Else
Counter = 1
While Counter <= UBound(file)
j = (2 * i) - 1
Workbooks.Open file(Counter)
Set wb = Workbooks("Strain End Point " & Counter & " - FEA Loop - Loading - (Timed).csv")
'End of column, needs + 3 to account for first 3 unused cells
k = Range("F4", Range("F4").End(xlDown)).Count + 3
'Loops through data, deletes negative values
For m = 4 To k
If Range("F" & m).value < 0 Or Range("F" & m).Offset(0, 1) < 0 Then
Range("F" & m).Delete
Range("F" & m).Offset(0, 1).Delete
'If cell is deleted, rechecks new value
m = m - 1
End If
Next m
Range("F4:G" & k).Copy
Workbooks(nom).Sheets(Counter + 1).Cells(4, j).PasteSpecial
wb.Close
'Opens next file
Counter = Counter + 1
Wend
End If
Next i
'Turns Screen Updating and Alert Displays back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
When MultiSelect is true, file will always be a variant array, even if only a single file is selected. Therefore you must iterate through each element of the array in order to check it against your mask.
With regard to your mask, I would suggest using the Like operator as it seems simpler and will probably run faster. Note the # replacing the regex pattern [0-9]) eg:
'Checks set pattern, displays error message if not correct file
Const strPattern as String = "Strain End Point # - FEA Loop - Loading - (Timed)" 'File Pattern
For I = LBound(file) To UBound(file)
If Not file(I) Like strPattern Then
MsgBox ("Select Loading Only")
Exit Sub
End If
Next I
I have a system which generates 3 text (.txt) files on a daily basis, with 1000's of entries within each.
Once the text files are generated we run a vbscript (below) that modifies the files by entering data at specific column positions.
I now need this vbscript to do an additional task which is to separate a column in one of the text files.
So for example the TR201501554s.txt file looks like this:
6876786786 GFS8978976 I
6786786767 DDF78676 I
4343245443 SBSSK67676 I
8393372263 SBSSK56565 I
6545434347 DDF7878333 I
6757650000 SBSSK453 I
With the additional task of seperating the column, data will now look like this, with the column seperated at a specific position.
6876786786 GFS 8978976 I
6786786767 DDF 78676 I
4343245443 SBSSK 67676 I
8393372263 SBSSK 56565 I
6545434347 DDF 7878333 I
6757650000 SBSSK 453 I
I was thinking maybe I could add another "case" to accomplish this with maybe using a "regex" pattern, since the pattern would be only 3 companies to find
(DDF, GFS and SBSSK).
But after looking at many examples, I am not really sure where to start.
Could someone let me know how to accomplish this additional task in our vbscript (below)?
Option Explicit
Const ForReading = 1
Const ForWriting = 2
Dim objFSO, pFolder, cFile, objWFSO, objFileInput, objFileOutput,strLine
Dim strInputPath, strOutputPath , sName, sExtension
Dim strSourceFileComplete, strTargetFileComplete, objSourceFile, objTargetFile
Dim iPos, rChar
Dim fileMatch
'folder paths
strInputPath = "C:\Scripts\Test"
strOutputPath = "C:\Scripts\Test"
'Create the filesystem object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get a reference to the processing folder
Set pFolder = objFSO.GetFolder(strInputPath)
'loop through the folder and get the file names to be processed
For Each cFile In pFolder.Files
ProcessAFile cFile
Next
Sub ProcessAFile(objFile)
fileMatch = false
Select Case Left(objFile.Name,2)
Case "MV"
iPos = 257
rChar = "YES"
fileMatch = true
Case "CA"
iPos = 45
rChar = "OCCUPIED"
fileMatch = true
Case "TR"
iPos = 162
rChar = "EUR"
fileMatch = true
End Select
If fileMatch = true Then
Set objWFSO = CreateObject("Scripting.FileSystemObject")
Set objFileInput = objWFSO.OpenTextFile(objFile.Path, ForReading)
strSourceFileComplete = objFile.Path
sExtension = objWFSO.GetExtensionName(objFile.Name)
sName = Replace(objFile.Name, "." & sExtension, "")
strTargetFileComplete = strOutputPath & "\" & sName & "_mod." & sExtension
Set objFileOutput = objFSO.OpenTextFile(strTargetFileComplete, ForWriting, True)
Do While Not objFileInput.AtEndOfStream
strLine = objFileInput.ReadLine
If Len(strLine) >= iPos Then
objFileOutput.WriteLine(Left(strLine,iPos-1) & rChar)
End If
Loop
objFileInput.Close
objFileOutput.Close
Set objFileInput = Nothing
Set objFileOutput = Nothing
Set objSourceFile = objWFSO.GetFile(strSourceFileComplete)
objSourceFile.Delete
Set objSourceFile = Nothing
Set objTargetFile = objWFSO.GetFile(strTargetFileComplete)
objTargetFile.Move strSourceFileComplete
Set objTargetFile = Nothing
Set objWFSO = Nothing
End If
End Sub
You could add a regular expression replacement to your input processing loop. Since you want to re-format the columns I'd do it with a replacement function. Define both the regular expression and the function in the global scope:
...
Set pFolder = objFSO.GetFolder(strInputPath)
Set re = New RegExp
re.Pattern = " ([A-Z]+)(\d+)( +)"
Function ReFormatCol(m, g1, g2, g3, p, s)
ReFormatCol = Left(" " & Left(g1 & " ", 7) & g2 & g3, Len(m)+2)
End Function
'loop through the folder and get the file names to be processed
For Each cFile In pFolder.Files
...
and modify the input processing loop like this:
...
Do While Not objFileInput.AtEndOfStream
strLine = re.Replace(objFileInput.ReadLine, GetRef("ReFormatCol"))
If Len(strLine) >= iPos Then
objFileOutput.WriteLine(Left(strLine,iPos-1) & rChar)
End If
Loop
...
Note that you may need to change your iPos values, since splitting and re-formatting the columns increases the length of the lines by 2 characters.
The callback function ReFormatCol has the following (required) parameters:
m: the match of the regular expression (used to determine the length of the match)
g1, g2, g3: the three groups from the expression
p: the starting position of the match in the source string (but not used here)
s: the source string (but not used here)
The function constructs the replacement for the match from the 3 groups like this:
Left(g1 & " ", 7) appends 4 spaces to the first group (e.g. GFS) and trims it to 7 characters. This is based on the assumption that the first group will always be 3-5 characters long.→ GFS
" " & ... & g2 & g3 prepends the result of the above operation with 2 spaces and appends the other 2 groups (8978976 & ).→ GFS 8978976
Left(..., Len(m)+2) then trims the result string to the length of the original match plus 2 characters (to account for the additional 2 spaces inserted to separate the new second column from the former second, now third, column).→ GFS 8978976
At first replace by regex pattern (\d+)\s+([A-Z]+)(\d+)\s+(\w+) replace with $1 $2 $3 $4
and split that by +. then ok.
Live demo
I am using an output file (CSV) wich is coming from an external source - used to do data scraping.
However, web pages that are "scrapped" doesn't have the same exaction pattern, so in the output file (Excel), I have column that are offset. Fortunaltly, the values contains the name of the header , so I am looking a solution to solve the "offset" problem.
PS: Some rows are offset, some not. The offset can be by 1, 2 or more cell, so i can't do: value(i+1) = i as there is no logic
Download File Here, or same info here:
FRAME BRAKES SADDLE WHEELS etc….
brakes: info1 saddle:info1 wheels:info1
frame:info2 brakes:info2 saddle:info2 wheels: info2
brakes: info3 saddle:info3 wheels:info3
I dont know if vlookUp, combined with some regex could do the trick,
What do you suggest ?
EDIT:
Download File Here
VBA CODE
Option Explicit
Sub test()
Dim Titles As Variant
Dim Data As Variant
Dim Dataline As String
Dim NumDataPoints As Long
Dim FirstTitle As String
Dim WhichTitle As Long
Dim Offset As Long
Dim rowcount As Long
Open "SORTcannodale2013.csv" For Input As #1
Line Input #1, Dataline
Titles = Split(Dataline, ",")
For Offset = 0 To UBound(Titles)
Cells(1, Offset + 1) = Titles(Offset)
Next
rowcount = 2
'While Not EOF(1)
Line Input #1, Dataline
Data = Split(Dataline, Chr$(34) & "," & Chr$(34))
FirstTitle = LCase(Left(Data(0), InStr(Data(0), vbLf) - 1))
For WhichTitle = 0 To UBound(Titles)
If Titles(WhichTitle) = FirstTitle Then Exit For
Next
For Offset = WhichTitle To UBound(Titles)
Cells(rowcount, Offset + 1) = Data(Offset - WhichTitle)
Next
rowcount = rowcount + 1
'Wend
Close #1
End Sub
The quickest way I could come up with was to read the CSV file in, and write it out to the spreadsheet myself.
I read the first line to get the titles.
I then read the second line, and inspect the first piece of data. I then compare this to the titles to get my offset.
I then write out the data, using the offset I have
Loop through the file until I get to the end, and quit.
This will always start writing in A1 on the current sheet. I'll leave it as an exercise to get it to write elsewhere
Option Explicit
Sub test()
Dim Titles As Variant
Dim Data As Variant
Dim Dataline As String
Dim NumDataPoints As Long
Dim FirstTitle As String
Dim WhichTitle As Long
Dim Offset As Long
Dim rowcount As Long
Open "test.csv" For Input As #1
Line Input #1, Dataline
Titles = Split(Dataline, ",")
For Offset = 0 To UBound(Titles)
Cells(1, Offset + 1) = Titles(Offset)
Next
rowcount = 2
While Not EOF(1)
Line Input #1, Dataline
Data = Split(Dataline, ",")
FirstTitle = UCase(Left(Data(0), InStr(Data(0), ":") - 1))
For WhichTitle = 0 To UBound(Titles)
If Titles(WhichTitle) = FirstTitle Then Exit For
Next
For Offset = WhichTitle To UBound(Titles)
Cells(rowcount, Offset + 1) = Data(Offset - WhichTitle)
Next
rowcount = rowcount + 1
Wend
Close #1
End Sub
There's no real reason to write your own CSV import function here. The file uploaded to DropBox has the fields enclosed in double-quotes and any double-quotes within the fields are correctly doubled up.
To get the file into Excel is as simple as:
Workbooks.OpenText Filename:="SORTcannodale2013.csv", _
DataType:=xlDelimited, TextQualifier:=xlTextQualifierDoubleQuote, _
ConsecutiveDelimiter:=True, Comma:=True
The header row doesn't actually have entries for all possible values. For example, "Rear Shock" and "Extras" are in the test data but are not represented in the header row. You should identify all possible values and construct your own header row that contains all of them.
Within each data entry, we have the field name then an embedded line feed (ASCII character 10) and then the data value. Splitting the entry into field name and value would just entail using the Split function as before with Chr$(10) as the delimiter.
Turning the data into a usable worksheet can be done by simply hardcoding the column number for each field name (e.g. in a Dictionary object), splitting out the field name from each entry, looking up the appropriate column number in the dictionary and outputting the data value to the appropriate cell.
If you are going to have an ongoing need to process this data then it may well be worth investing the time to convert it into a more standardised format (e.g. XML). Nothing in the data is particularly suited to being processed in Excel. To turn it into XML, you would need to do some more work on escaping some of the characters in the data. If you then needed to use Excel then it would be easy enough to import the XML data
I'm not really expert in VBA and I have a problem with my code and I don't know how to solve it. (The code is from: http://siddharthrout.wordpress.com/2011/07/29/excel-data-validationcreate-dynamic-dependent-lists-vba/)
I'm working with 8 dynamic dependent lists, and I thought the best way to automate the process and avoid to modify the macro in a future if I modify the lists was a VBA code.
Trying to find the correct code, I'm just working with to lists. For after, apply it for all lists.
I've checked the code and I discovered that there's an error (method 'intersect' of object '_global' failed) because I'm comparing two ranges from a different worksheets.
My code is:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, LastRow As Long, n As Long
Dim MyCol As Collection
Dim SearchString As String, Templist As String
Application.EnableEvents = False
On Error GoTo Whoa
' Find LastRow in Col A
LastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Sheet2.Columns(1)) Is Nothing Then
Set MyCol = New Collection
' Get the data from Col A into a collection
For i = 2 To LastRow
If Len(Trim(Sheet2.Range("A" & i).Value)) <> 0 Then
On Error Resume Next
MyCol.Add CStr(Sheet2.Range("A" & i).Value), CStr(Sheet2.Range("A" & i).Value)
On Error GoTo 0
End If
Next i
' Create a list for the Data Validation List
For n = 1 To MyCol.Count
Templist = Templist & "," & MyCol(n)
Next
Templist = Mid(Templist, 2)
Range("A2").ClearContents: Range("A2").Validation.Delete
' Create the Data Validation List
If Len(Trim(Templist)) <> 0 Then
With Range("A2").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Templist
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
' Capturing change in cell A2
ElseIf Not Intersect(Target, Range("A2")) Is Nothing Then
SearchString = Range("A2").Value
Templist = FindRange(Sheet2.Range("A2:A" & LastRow), SearchString)
Range("B2").ClearContents: Range("B2").Validation.Delete
If Len(Trim(Templist)) <> 0 Then
' Create the DV List
With Range("B2").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Templist
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
' Function required to find the list from Col B
Function FindRange(FirstRange As Range, StrSearch As String) As String
Dim aCell As Range, bCell As Range, oRange As Range
Dim ExitLoop As Boolean
Dim strTemp As String
Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:= _
xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Do While ExitLoop = False
Set aCell = FirstRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Else
ExitLoop = True
End If
Loop
FindRange = Mid(strTemp, 2)
End If
End Function
Into the Sheet1, I just want the cells to select the list options and into the Sheet2, I want the all dynamic and dependent lists.
Is there any possibility to compare two ranges from a different worksheets using these algorithm? Or an alternative code to create a pick list for 8 depending and dynamic lists?
I am going to turn you to this page that describes dynamic dependent list usage very well.
Dynamic Dependent Lists
Perhaps you don't need VBA at all, unless you have to alter these on the fly, or based on some other variable. It's always best to use Excel's built-in functionality first, and code 2nd.
In case you are wandering, you can get around having lists on two different sheets by setting the named range scope to the entire workbook.
Edit: Adding answer to direct VBA error.
Since you didn't say, not sure if your Intersect is breaking here:
If Not Intersect(Target, Sheet2.Columns(1)) Is Nothing Then
but I think it is. Try this:
If Not Intersect(Target, Columns(1).EntireColumn) Is Nothing Then