I am just wondering how i can skip over an error if the array is not full? For example, 1 loop goes over whether the array has a first and last name, if there is no last name i would like the script to continue.
FullName = ActiveSheet.Cells(37, ii).Value
Name = Split(FullName, " ")
For intCount = LBound(Name) To UBound(Name)
sData.Range("C" & iii).Value = Name(0)
sData.Range("D" & iii).Value = Name(1)
Next
If Name(1) is empty then how can the code continue?
Since the two columns are consecutive, you can just paste the array in-place, using Range.Resize to dump the array across as many columns as needed - the only thing to watch for is if Name can contain more than a single space:
FullName = ActiveSheet.Cells(37, ii).Value
Name = Split(FullName, " ")
If UBound(Name) <= 1 Then
sData.Range("C" & iii).Resize(, UBound(Name) + 1).Value = Name
Else
'there was more than one space...
End If
If you want to avoid using On Error Resume Next, you can try this:
FullName = ActiveSheet.Cells(37, ii).Value
Name = Split(FullName, " ")
If Len(Join(Name)) > 0 Then
sData.Range("C" & iii).Value = Name(0)
sData.Range("D" & iii).Value = Name(1)
End If
which was originally posted here. Join essentially reverts to the FullName value but without the space. Alternatively, you could just use If InStr(1, FullName, " ", vbBinaryCompare) > 0 Then.
With some test values
Option Explicit
Sub test()
Dim ii As Long
Dim iii As Long
ii = 2
iii = 3
Dim FullName As String
Dim Name() As String
With ActiveSheet
FullName = .Cells(37, ii).Value
If InStrRev(FullName, " ", -1) > 0 Then 'space present
Name = Split(FullName, " ")
If UBound(Name) > 1 Then Exit Sub 'there was more than one space present. Handling this was not specified so exit sub.
.Range("C" & iii).Value = Name(0)
.Range("D" & iii).Value = Name(1)
Else
.Range("C" & iii).Value = FullName
.Range("D" & iii).Value = vbNullString
End If
End With
End Sub
Related
I paste data from elsewhere to a userform.
For example (the copied string)
Clinical: history of heart disease
Labs: elevated cholesterol on 8Aug
Meds: just started cholesterol medication
Supplements: none
Allergies: none
Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting
I want to paste the above string into textbox1.
The string should then be split into appropriate headings on textboxes 2 to 7 on the same userform.
In textbox 2, I want everything between "Clinical:" and "Labs:"
"history of heart disease" without the headings.
If “Labs:” is not present, I want everything between Clinical: and Meds (or next heading)
At this point, I think a loop to repeat this process but for the next items
(e.g. texbox 3 = everything between Labs: and Meds – or next heading; Textbox4 = everything between Meds: and Supplements) – or next heading; etc.
Private Sub CommandButton1_Click()
Dim strnames(1 To 6) As String
strnames(1) = "Clinical: "
strnames(2) = "Labs: "
strnames(3) = "Meds: "
strnames(4) = "Supps: "
strnames(5) = "Allergies: "
strnames(6) = "Activity: "
strnames(7) = "NFPE: "
Dim check As Integer
str1 = TextBox1
x = 1
For box = 1 To 6
If InStr(TextBox1.Text, strnames(1)) > 0 Then
str2 = SuperMid(str1, strnames(x), strnames(x + 1))
TextBox2 = str2
End If
If InStr(TextBox1.Text, strnames(1)) = 0 Then
TextBox2 = "none"
End If
Next box
End sub
This is the code that I have been using (from wellsr.com) to capture the data between word1 and word2 of the array. The problem occurs when a word in the array is not present at which point it adds all of the text following the first word.
Public Function SuperMid(ByVal strMain As String, str1 As String, str2 As String,
Optional reverse As Boolean) As String
Dim i As Integer, j As Integer, temp As Variant
On Error GoTo errhandler:
If reverse = True Then
i = InStrRev(strMain, str1)
j = InStrRev(strMain, str2)
If Abs(j - i) < Len(str1) Then j = InStrRev(strMain, str2, i)
If i = j Then 'try to search 2nd half of string for unique match
j = InStrRev(strMain, str2, i - 1)
End If
End If
If reverse = False Then
i = InStr(1, strMain, str1)
j = InStr(1, strMain, str2)
If Abs(j - i) < Len(str1) Then j = InStr(i + Len(str1), strMain, str2)
If i = j Then 'try to search 2nd half of string for unique match
j = InStr(i + 1, strMain, str2)
End If
End If
If i = 0 And j = 0 Then GoTo errhandler:
If j = 0 Then j = Len(strMain) + Len(str2) 'just to make it arbitrarily large
If i = 0 Then i = Len(strMain) + Len(str1) 'just to make it arbitrarily large
If i > j And j <> 0 Then 'swap order
temp = j
j = i
i = temp
temp = str2
str2 = str1
str1 = temp
End If
i = i + Len(str1)
SuperMid = Mid(strMain, i, j - i)
Exit Function
errhandler:
MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
End
End Function
Sometimes you need to add a little complication to make things easier. The code below may be of interest.
Option Explicit
' This code requires a reference to the Microsoft Scripting Runtime
Public Sub Test()
Dim myHistory As Scripting.Dictionary
Set myHistory = GetHistoryDictionary("Clinical: history of heart disease Labs: elevated cholesterol on 8AugMeds: just started cholesterol medication Supplements: none Allergies: none Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting)")
Debug.Print VBA.Join(myHistory.keys, vbCrLf)
Debug.Print VBA.Join(myHistory.Items, vbCrLf)
Debug.Print
If myHistory.Exists("Labs") Then
Debug.Print "The Lab report was: " & myHistory.Item("Labs")
End If
Debug.Print
If myHistory.Exists("Heamatology") Then
Debug.Print "The Heamatolofy report was: " & myHistory.Item("Heamatology")
Else
Debug.Print "The Heamtology report was: " & "Not Present"
End If
End Sub
Public Function GetHistoryDictionary(ByVal ipString As String) As Scripting.Dictionary
' Create an array of the labes in the input strings
Static myLabels As Variant
If VBA.IsEmpty(myLabels) Then
myLabels = Split("Clinical:,Labs:,Meds:,Supps:,Allergies:,Activity:,NFPE:", ",")
End If
' Add a character we can use as a separator with SPlit
Dim myLabel As Variant
For Each myLabel In myLabels
ipString = VBA.Replace(ipString, myLabel, "#" & myLabel)
Next
' remove characters until we have removed the first separator character
Do Until VBA.Left(ipString, 1) = "#"
ipString = VBA.Mid$(ipString, 2)
Loop
ipString = VBA.Mid$(ipString, 2)
'Get an array of Label/Message
Dim myItems As Variant
myItems = VBA.Split(ipString, "#")
'Split the label/message and put into a scripting.dictionary
Dim myHistory As Scripting.Dictionary
Set myHistory = New Scripting.Dictionary
Dim myItem As Variant
For Each myItem In myItems
Dim mySPlit As Variant
mySPlit = VBA.Split(myItem, ":")
myHistory.Add mySPlit(0), mySPlit(1)
Next
Set GetHistoryDictionary = myHistory
End Function
Building on your code:
First ensure you have Option Explicit at the top of all your modules as this will help pick out any simple errors.
In your UserForm you could have text boxes labeled TextBox1, TextBox2 etc. Then you could use this for the command button code:
Private Sub CommandButton1_Click()
Dim strnames(1 To 7) As String
strnames(1) = "Clinical: "
strnames(2) = "Labs: "
strnames(3) = "Meds: "
strnames(4) = "Supps: "
strnames(5) = "Allergies: "
strnames(6) = "Activity: "
strnames(7) = "NFPE: "
Dim str1 As String
str1 = TextBox1.Text
' It makes the code clearer if you are explicit about what you want
' from your text box - .Text (or .Value), even if VBA will
' give you its value if you don't specify it.
Dim str2 As String
Dim ctlControl As Control
Dim lngTextBoxNumber As Long
' You need to loop through all the controls on the form, and then
' determine which are the ones you want to alter. This assumes each
' textbox you are interested in is named in the form
' TextBox1, TextBox2 etc. To make code maintenance easier, I would
' probably put this kind of identification information on the
' controls' tag properties - that way if you rename the controls or
' you add a text box which is for something else, you won't break
' the code. You would then be reading this information off the
' .Tag property rather than .Name.
For Each ctlControl In Me.Controls
If Mid$(ctlControl.Name, 1, 7) = "TextBox" Then
lngTextBoxNumber = CLng(Mid$(ctlControl.Name, 8))
If lngTextBoxNumber > 1 And lngTextBoxNumber < UBound(strnames) Then
str2 = SuperMid(str1, strnames(lngTextBoxNumber), strnames(lngTextBoxNumber + 1))
If str2 = vbNullString Then
str2 = "none"
End If
ctlControl.Text = str2
End If
End If
Next ctlControl
End Sub
SuperMid seems to be quite an unforgiving function - as you have it, if it can't find the text before and after the text you are looking for, it will fail with an error: it might be better for it to return an empty string - otherwise your code will fail not all the strnames are present in your original string.
I altered the end of that function to look like this:
Exit Function
errhandler:
'MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
SuperMid = vbNullString
End Function
As it stands, your code would fail to pick up some of the information if items are left out, or had been entered in a different order: see freeflow's answer to avoid this.
I would skip the array because what you're really looking to do is to extract the phrase following the keyword. The example below shows how you can use a function to isolate the phrase.
Function ExtractByKeyword(ByVal source As String, _
ByVal keyword As String) As String
'--- extracts a phrase (substring) from the given source,
' beginning with the keyword and ending with the next
' (unknown) keyword.
' Keywords are delimited by a preceding space ' ' and
' followed by a colon ":" or EOL
Dim pos1 As Long
pos1 = InStr(1, source, keyword, vbTextCompare)
If pos1 = 0 Then
'--- the keyword was not found, so return a null string
ExtractByKeyword = vbNullString
Exit Function
End If
Dim phrase As String
'--- skip over the keyword and find the next keyword
' (i.e. look for the next colon)
Dim pos2 As Long
pos2 = InStr(pos1 + Len(keyword) + 1, source, ":", vbTextCompare)
If pos2 = 0 Then
'--- this is the last keyword and phrase in the source
phrase = Right$(source, Len(source) - pos1 - Len(keyword) - 1)
Else
'--- now work backwards from the second keyword to find the
' end of the phrase (which is the space just before the
' second keyword
Dim pos3 As Long
pos3 = InStrRev(source, " ", pos2, vbTextCompare)
Dim startsAt As Long
Dim phraseLen As Long
startsAt = pos1 + Len(keyword) + 2
phraseLen = pos3 - startsAt
phrase = Mid$(source, startsAt, phraseLen)
End If
ExtractByKeyword = phrase
End Function
I used the test routine below to check the extraction:
Option Explicit
Sub test()
Const medInfo As String = "Clinical: history of heart disease" & _
" Labs: elevated cholesterol on 8Aug" & _
" Meds: just started cholesterol medication" & _
" Supplements: none" & _
" Allergies: none" & _
" Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting"
Dim phrase As String
phrase = ExtractByKeyword(medInfo, "Labs")
If phrase <> vbNullString Then
Debug.Print " Labs -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Clinical")
If phrase <> vbNullString Then
Debug.Print " Clinical -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Activity")
If phrase <> vbNullString Then
Debug.Print " Activity -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Meds")
If phrase <> vbNullString Then
Debug.Print " Meds -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Allergies")
If phrase <> vbNullString Then
Debug.Print "Allergies -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
End Sub
I have the following data
Name ID Value
Alice 12C 500
Bob 14 60
Dan 15C 64
Dan 1C 25
Alice 4 556
Bob 11 455
In my data, Alice has both numerical (4) and string+numerical ID (12C) and I want to delete all Alice rows, while I want to hold on to data of names where their ID is strictly numeric (Bob 11, 14) or strictly string+numeric (Dan 15C , 1C).
First I make an array of unique Name entries:
FinalRow = 7
Name_column = 1
n = 1
Dim FID_Array() As Variant
ReDim Preserve FID_Array(1 To 1)
FID_Array(1) = Cells(2, Name_column)
For j = 3 To FinalRow
If Cells(j, Name_column).Value <> FID_Array(n) Then
ReDim Preserve FID_Array(1 To n + 1)
FID_Array(n + 1) = Cells(j, Name_column).Value
n = n + 1
End If
Next j
Then I make an Array of the row numbers that contain a particular Name
ReDim Preserve Count_FID_Array(1 To 1) As Variant
n = 1
range_FID = A2:A7
' In my actual code this is Range_FID
' range_FID = Cells(2, FolderId_column).Address & ":" & Cells(FinalRow, FolderId_column).Address
For Each itm5 In FID_Array()
Count_FID_Array(n) = Application.CountIf(" & range_FID & ", " & itm5 & ")
ReDim Preserve Count_FID_Array(1 To n + 1)
n = n + 1
Next itm5
I don't think my CountIf is working. I have tried to store the value of Count_FID_Array in another cell in a different sheet but I am getting #value!
If I got the countIf to work then I was going to sort the data by name, then double loop to check the ID variable the next "n" times to see if the last digit was "C" for all of them or to check if the ID was numeric for all of them.
Can you please point out why my countif is not working and is there a smarter way to do this?
I am using arrays of names here because in the end I want to feed the array into an autofilter and delete the rows that I don't want.
Update 1 3:45 PM Nov 21 2013: I have solved this as following:
I basically created three columns. First column was 0 or 1 depending on if the the ID was all numbers. The second column was 0 or 1 depending on if the last digit was "C" (in my real work the last two digits are "IB" ) and finally I compared the frequency of these occurences to the frequency of the Name itself. If any of those match then I give it the number 1 else 0. I use this index later to autofilter.
Now I'll try to use zx8754's shorter formula in the VBA code and I will try to address the issues regarding Countif that Joe has raised.
Sub conditionsforsubfolders()
FinalColumn = Cells(1, Columns.Count).End(xlToLeft).Column
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Columns(FinalColumn + 1).Insert
ActiveWorkbook.ActiveSheet.Columns(FinalColumn + 2).Insert
ActiveWorkbook.ActiveSheet.Columns(FinalColumn + 3).Insert
Isnumber_Column = FinalColumn + 1
Is_IB_Column = FinalColumn + 2
Exceptions_Column = FinalColumn + 3
Cells(1, Isnumber_Column) = "Number"
Cells(1, Is_IB_Column) = "Letters"
Cells(1, Exceptions_Column) = "Exceptions"
For j = 1 To FinalColumn
If Cells(1, j).Value = "TradeId" Then
TradeId_column = j
ElseIf Cells(1, j).Value = "Total Notional per folder" Then
Total_Notional_Per_Folder_Column = j
ElseIf Cells(1, j).Value = "ExternalId" Then
ExternalId_Column = j
ElseIf Cells(1, j).Value = "FolderId" Then
FolderId_column = j
End If
Next j
range_FolderId_fixed = Cells(2, FolderId_column).Address & ":" & Cells(FinalRow, FolderId_column).Address
range_TradeId_fixed = Cells(2, TradeId_column).Address & ":" & Cells(FinalRow, TradeId_column).Address
range_Isnumber = Cells(2, Isnumber_Column).Address & ":" & Cells(FinalRow, Isnumber_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_Isnumber_fixed = Cells(2, Isnumber_Column).Address & ":" & Cells(FinalRow, Isnumber_Column).Address
range_Is_IB = Cells(2, Is_IB_Column).Address & ":" & Cells(FinalRow, Is_IB_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_Is_IB_fixed = Cells(2, Is_IB_Column).Address & ":" & Cells(FinalRow, Is_IB_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_FolderId_cell = Cells(2, FolderId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_TradeId_cell = Cells(2, TradeId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_Exceptions = Cells(2, Exceptions_Column).Address & ":" & Cells(FinalRow, Exceptions_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Range(range_Isnumber).Formula = "=Isnumber(" & range_TradeId_cell & ")*1"
Range(range_Is_IB).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)= ""IB"")*1"
Range(range_Exceptions).Formula = "=(SUMIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "," & range_Isnumber_fixed & ")= COUNTIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "))*1 +(SUMIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "," & range_Is_IB_fixed & ")= COUNTIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "))*1 "
Worksheets("Sheet1").UsedRange.AutoFilter Field:=7, Criteria1:="=1"
End Sub
Formula solution, no VBA:
=IF(SUMPRODUCT(--($A$2:$A$7=A2),--(ISNUMBER($B$2:$B$7)))=1,"delete","keep")
The problem with your CountIF call is that you're passing a poorly-formed string. You're literally passing "range_FID & ", " & itm5".
First, you set to properly define range_fid:
Dim range_fid As Range
Set range_fid = [A2:A7]
The call CountIF with:
count_fid_array(n) = Application.WorksheetFunction.CountIf(range_fid, itm5)
With that said, I would go about it differently:
Dim c As Range
Dim people As Collection: Set people = New Collection
Dim person As Collection
Dim code As String
For Each c In Range(Range("a2"), Range("a2").End(xlDown)) ' loop through all rows
If IsNumeric(c.Offset(0, 1)) Then ' check if the ID is numeric or not
code = "num"
Else
code = "alphanum"
End If
On Error Resume Next ' Needed in order to avoid error when person already exists in collection
Set person = New Collection
person.Add c.Value, "name"
person.Add code, "code"
people.Add person, c.Value ' will only be added if name doesn't already exist in collection
On Error GoTo 0
If people(c.Value)("code") <> code Then ' if the format (alpha/num) of the ID on the current row is different than the format of a previous row for this name....
people(c.Value).Remove ("code") ' then set the code to "diff"
people(c.Value).Add "diff", "Code"
End If
Next
For Each person In people ' just display the content; you can take appropriate action here
Debug.Print person("name") & ": " & person("code")
Next
The result is a Collection containing names and a code for each. The code will be one of:
num: all values for a name are numeric (Bob)
alphanum: all values for a name are alphanumeric (Dan)
diff: name has at least one each of numeric and alphanumeric (Alice)
Note that this could be done a little clearer with a Dictionary instead of a Collection, or with a Class, but I chose to take the most straightforward approach.
I have some VBA I am wanting to use to update and add data to a table on an SQL server. I have been muddling through with limited knowledge of this functionality within VBA all day, searching various sites and not really getting any answers to make things click into place and not getting any response when posting it elsewhere. Hopefully I can get this solved here.
So, I have the following code that I have cobbled together:
Sub connectsqlserver()
Dim conn As ADODB.Connection
Dim recset As ADODB.Recordset
Set conn = New ADODB.Connection
Set recset = New ADODB.Recordset
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim msgstrng As String
Dim newstring As String
If conn.State <> 0 Then
conn.Close
End If
With conn
.ConnectionString = "Driver={SQL Server};server=sage500;Database=CS3Live;Uid=sa;Pwd=pass; ReadOnly=False;"""
.ConnectionTimeout = 5
.Open
End With
recset.Open Source:="custinfosheetdata", ActiveConnection:=conn, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Sheets("Changes").Range("A1").Value <> 0 Then
For i = 1 To Sheets("Changes").Range("A1").Value
recset.Find "Col2 = " & Sheets("Changes").Cells(2, i + 2) 'find the value in B from B3 onwards
'Do something
Next i
Sheets("Changes").Rows("3:" & i + 2).Delete xlUp
Else
i = 0
End If
If Sheets("New").Range("A1").Value <> 0 Then
For j = 1 To Sheets("New").Range("A1").Value
newstring = ""
For k = 1 To 38
If k = 38 Then
newstring = newstring & "'" & Cells(j + 2, k).Value & "'"
Else
newstring = newstring & "'" & Cells(j + 2, k).Value & "', "
newstring = Format(newstring, "")
End If
Next k
Debug.Print (newstring)
With recset
.AddNew (newstring)
.Update
End With
Next j
Sheets("New").Rows("3:" & j + 2).Delete xlUp
Else
j = 0
End If
recset.Close
conn.Close
If i = 0 And j = 0 Then
msgstring = "No Changes/New Data to add"
Else
If i = 0 And j <> 0 Then
msgstring = "No Changes and " & j & " New Customers added"
Else
If i <> 0 And j = 0 Then
msgstring = i & " Changes and no New Customers added"
Else
msgstring = i & " Changes and " & j & " New Customers added"
End If
End If
End If
End Sub
Part 1: This currently throws out an error at "With recset.AddNew..." (3001) saying that arguments are of the wrong type. The table it is going to is formatted as nvarchar(255) and all the data is formatted as text in the various fields so I am not entirely sure whats happening there.
Part 1 code:
If lastrow <> 0 Then
For j = 1 To lastrow
For k = 1 To lastfield
If k = lastfield Then
newstring = newstring & "'" & Cells(j + 2, k).Value & "'"
Else
newstring = newstring & "'" & Cells(j + 2, k).Value & "', "
newstring = Format(newstring, "")
End If
Next k
With recset
.AddNew (newstring)
.Update
End With
Next j
End If
Part 2: As my knowledge of VBA for ADODB connections is awful at best, I cannot figure out how to continue once I have found the row I require, hence the "'Do something" line. What I need this to do is find the record matched from column B in the "Changes" excel table and then edit that row in the SQL table to match it. I can't figure out how to do this though.
Part 2 code:
If lastrow <> 0 Then
For i = 1 To lastrow
recset.Find "Col2 = " & Sheets("Changes").Cells(2, i + 2) 'find the value in B from B3 onwards
' Do something
Next i
End If
EDIT: I have this from the debug.print which may help some people visualise this a bit more:
"23/07/13","TEST123","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test"
This is for a full line (so therefore the Field List should not be required as this is data for every column in the correct order).
From what you posted, I believe you've been trying to concatenate all the values into a string separated by ','. (correct me if I'm wrong)
This answer is only useful if you wanted to append new data, if you want to find a specific record in the database and update it then its a completely different story.
The "Add New" method takes in two arguments.
The list of fields in array format
The list of values in array format
Unless you have only one field or one value to add you should put them into array before using the "Add New" method.
A possible way of constructing the arrays:
For i = 0 to count_of_fields
aryFields(i) = field_value
Next
For i = 0 to count_of_values
aryValues(i) = value
Next
recset.AddNew aryFields,aryValues
recset.Update
Let me know if that helps!
Will post this now actually instead of Monday or else I may forget.
Ended up being the neatest solution as working with arrays in this case seemed to fail a lot and they are a lot harder to debug. This at least made it a lot simpler.
Also, was good finding out that once you have found the row (my part 2 question), that it is in fact the same process as with .addnew (which was what I was not sure of)
With conn
.ConnectionString = "Driver={SQL Server};server=sage;Database=CS3Live;Uid=sa;Pwd=pass; ReadOnly=False;"""
.Open
End With
recset.Open Source:="custinfosheetdata", ActiveConnection:=conn, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Sheets("Changes").Range("A1").Value <> 0 Then
For i = 3 To LastRow
With recset
.Find "Col2 = " & "'" & Sheets("Changes").Range("B" & i) & "'"
For k = 1 To 38
strField = Sheets("Changes").Cells(2, k).Value
varValue = Sheets("Changes").Cells(i, k).Value
.Fields(strField).Value = varValue
Next k
.Update
End With
Next i
Else
i = 0
End If
If Sheets("New").Range("A1").Value <> 0 Then
For j = 3 To LastRow
With recset
.AddNew
For k = 1 To 38
strField = Sheets("New").Cells(2, k).Value
varValue = Sheets("New").Cells(j, k).Value
.Fields(strField).Value = varValue
Next k
.Update
End With
Next j
Else
j = 0
End If
... etc
So anyway, thanks to all that tried helping on here. I still cannot understand why arrays were not working though.
I am having trouble with an asp page that contains a random function to display a random number of random records. The way I have the code now, as shown below, nothing appears on the page even though there are several records that match the criteria.
Out of 500 records I have in my database, about 70 match the criteria, but form some reason, they never seem to fall within the plist variable, to be used in the query.
When I change the max number to a lower number, say 10, I get an error message that the EOF has been found or no more records are available. Using debugging code, I couldnt find anything out of the ordinary, just the fact that from all the 100 records input into the plist, none of them match the records from the main criteria.
I am posting the entire code here. Maybe someone can catch what may be causing to not work properly.
Sub GetRandomDomains
dim conn, maxrecords, count, webname
dim randomrs, sql
'If (conn.State = adStateClosed) Then
OpenDB conn
'End If
count=0
maxrecords=100
KeywordColumnGetRandomKeywords conn, maxrecords, sql
If sql="" then
conn.close
set conn=nothing
Response.Write(" NOT AVAILABLE")
exit sub
end if
set randomrs=conn.execute(sql)
Response.Write("<ul id='catnav'>")
do While Not randomrs.EOF and count<maxrecords
If isnull(randomrs("sitename")) Then
webname=randomrs("domain")
Else
webname=randomrs("sitename")
End if
Response.Write "<li> " & webname &"</li>"
count=count+1
randomrs.movenext
loop
Response.Write("</ul>")
CloseSet randomrs
CloseDB conn
end sub
Sub KeywordColumnGetRandomKeywords (conn,maxrecords,sql)
dim i, id, index, plist, rs, sqlstr, sortstr
plist=""
Set rs=Server.CreateObject("ADODB.Recordset")
sqlstr="SELECT domainid FROM domains"
sqlstr=sqlstr
Debugwrite sqlstr, "sqlstr for random domains"
rs.Open sqlstr,conn,3,3
If rs.eof then
CloseSet rs
Response.Write(" EMPTY")
sql=""
exit sub
end if
Debugwrite rs("domainid"), "rs for random domains"
Dim arrData ' Array to Store Data
Dim arrSequence ' Array to Hold Random Sequence
Dim iArrayLooper ' Integer for Looping
Dim iarraysize ' Size of Data Array
If xdbasetype="Local" Then
iarraysize=cint(rs.recordcount)
else
iarraysize=cint(GetRecordcount (conn))
end if
Debugwrite GetRecordcount(conn), "getrecordcount for random domains array"
Debugwrite(IsArray(iarraysize)), "random domains count array"
'if (cint(GetRecordcount(conn)))= 0 or isnull(cint(GetRecordcount(conn))) then
'Exit Sub
'End if
redim arrdata(cint(iarraysize))
for i = 0 to iarraysize-1
arrData(i)=rs(0)
rs.movenext
next
rs.close
Set rs = Nothing
If iarraysize<maxrecords then
maxrecords=iarraysize
end if
' Get an array of numbers 0 to array size randomly sequenced.
arrSequence = Resequencearray(iArraySize)
for i = 0 to maxrecords-1
index=arrsequence(i)
id=arrdata(index)
if plist<>"" then
plist=plist & ","
end if
plist=plist & id
Next
sql="select domainid, domain, sitename,sitematch,altmatch from domains"
sql = sql & " WHERE restricted=0 and(sitematch like '%" & xsitematch & "%' or altmatch like '%" & xaltmatch & "%')"
sql = sql & " and domainid In (" & plist & ") "
Debugwrite sql, "first sql for random domains"
end sub
Function ResequenceArray(iArraySize)
Dim arrTemp()
Dim I
Dim iLowerBound, iUpperBound
Dim iRndNumber
Dim iTemp
' Set array size
ReDim arrTemp(iArraySize - 1)
Randomize
iLowerBound = LBound(arrTemp)
iUpperBound = UBound(arrTemp)
For I = iLowerBound To iUpperBound
arrTemp(I) = I
Next
' Loop through the array once, swapping each value
' with another in a random location within the array.
For I = iLowerBound to iUpperBound
iRndNumber = Int(Rnd * (iUpperBound - iLowerBound + 1))
' Swap Ith element with iRndNumberth element
iTemp = arrTemp(I)
arrTemp(I) = arrTemp(iRndNumber)
arrTemp(iRndNumber) = iTemp
Next 'I
' Return our array
ResequenceArray = arrTemp
End Function
'***********************************************************************
' get record count for mysql
'************************************************************************
Function GetrecordCount(conn)
dim sqlstr, rs, rcount
sqlstr="select count(domainid) FROM domains WHERE restricted=0 and (domaingroup='" & xdomaingroup & "' or altmatch like '%" & xaltmatch & "%')"
Debugwrite sqlstr, "sqlstr for random domains"
set rs=conn.execute(sqlstr)
if rs.eof then
rcount=0
else
rcount=rs(0)
end if
CloseSet rs
Getrecordcount=cint(rcount)
Debugwrite rcount, "getrecordcount for random domains"
End function
Okay. There may be a far more simple way of approaching this. Here's a piece of code that gets the data as an array - far simpler and we have much more control over what's in it...
'Constants relating to the following routines...
const C_NO_DATA = "NO_DATA" 'Used when no data is returned to a consuming routine
const C_ERROR = "ERROR" 'Used when an error is generated
'GetDataSet
' Returns a table of data based on the supplied SQL statement and connection string.
'Parameters:
' sqlString (string) - The SQL string to be sent.
' connString (string) - The database connection string.
'Usage:
' dataSet = GetDataSet(sqlString, connString)
'Description:
' This function generates a table of information in a 2 dimensional array. The first dimension represents the columns
' and the second the rows. If an error occurs while the routine is executing the array and the base index (0,0) is set
' to C_ERROR, (0,1) to the VBScript error index, and (0,2) to the VBScript error description.
function GetDataSet(sqlString, connString)
'Initialise...
dim returnVal, rsData
on error resume next
'Define and open the recordset object...
set rsData = Server.CreateObject("ADODB.RecordSet")
rsData.Open sqlString, connString, 0, 1, 1
'Initialise an empty value for the containing array...
redim returnVal(0,0)
returnVal(0,0) = C_NO_DATA
'Deal with any errors...
if not rsData.EOF and not rsData.BOF then
'Store the data...
returnVal = rsData.GetRows()
'Tidy up...
rsData.close
set rsData = nothing
select case err.number
case 3021 'No data returned
'Do nothing as the initial value will still exist (C_NO_DATA)
case 0 'No error
'Do nothing as data has been returned
case else
redim returnVal(4,0)
returnVal(0,0) = C_ERROR
returnVal(1,0) = err.number
returnVal(2,0) = err.description
returnVal(3,0) = sqlString
returnVal(4,0) = connString
end select
end if
on error goto 0
'Return the array...
GetDataSet = returnVal
end function
Okay, so we read the data we're after into an array. Note that I don't know where your xaltmatch and xsitematch variables come from so you'll need to supply these at some point...
Dim ds, sql
sql = _
"SELECT " & _
"domainid, " & _
"domain, " & _
"sitename, " & _
"sitematch, " & _
"altmatch " & _
"FROM " & _
"domains " & _
"WHERE " & _
"restricted=0 AND " & _
"(sitematch LIKE '%" & xsitematch & "%' OR " & _
"altmatch LIKE'%" & xaltmatch & "%') AND " & _
"domainid IN (" & plist & ") "
ds = GetDataSet(sql, conn)
The ds variable now contains an array of elements pulled from the database. All we need to do now is loop through the required number of times...
dim row, rows, used, randoms, col, cols, rc, cc
rows = UBound(ds, 2) 'Get the upper bound of the second array dimension
cols = UBound(ds, 1) 'Get the number of columns for writing to the page
randoms = 70 'Total number of randoms we need
used = ","
for rc = 1 to randoms
'Just in case we don't want to repeat the same row...
do
row = int(rnd(1)*rows) 'Zero based - we don't need to add 1
until instr(used, "," & row & ",")) = 0
'Add our random row to the list...
used = used & row & ","
'Write our output to the page...
response.write("<table>")
for cc = 0 to cols
response.write("<tr>")
response.write("<td>")
response.write(ds(cc, row))
response.write("</td>")
response.write("</tr>")
next 'cc
response.write("</table>")
next 'rc
The GetDataSet code is part of my stock functions, so I know that works, but I will hold my hand up and say that I haven't tested the rest of it.
Have a bash with this one, Luis, and let me know how you get on.
I'm using VB 2010 Express to access a database in .mdb format.
I want to find the row that contains a specific string of characters and numbers, so I wrote this while loop. I'm using If statement to make sure the loop doesn't exceed the maximum rows ( MaxRows ) and throw an error. The result it keeps giving : " No record found " even though string does exist in the database. What am I doing wrong?
notes: inc is used to increment the row. message box is only to view the variables values
Code:
Dim lpn As String
Dim lpn2 As String
inc = 0
lpn = TextBox5.Text
lpn2 = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(7)
MsgBox(lpn & " " & lpn2 & " ")
While lpn <> lpn2
If inc <> MaxRows - 1 Then
inc = inc + 1
lpn2 = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(7)
MsgBox(lpn & " " & lpn2)
Else
MsgBox("No record found.")
Exit While
End If
End While
TextBox1.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(1)
TextBox2.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(2)
TextBox3.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(3)
TextBox4.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(4)
ComboBox1.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(5)
ComboBox2.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(6)
TextBox5.Text = ds.Tables("RegisteredCarsDataSet").Rows(inc).Item(7)