i try to make auto number based on format string, date and counter like USR20180815001, USR20180815002, when the day/date change it reset the counter to USR20180806001, USR20180806001, and so on. here is my code so far....
Sub AutomaticNumber()
Call Connection
Set Rs_User = New ADODB.Recordset
Rs_User.Open "SELECT * FROM TBL_USER WHERE id_user IN (SELECT
MAX(id_user)FROM TBL_USER)ORDER BY id_user DESC", Conn
Rs_User.Requery
Dim x As String * 15
Dim count As Long
With Rs_User
If .EOF Then
x = "USR" + Format(Date, "yyyymmdd") + "001"
NewNumber = x
Else
If Left(!id_user, 8) <> Format(Date, "yyyymmdd") Then
x = "USR" + Format(Date, "yyyymmdd") + "001"
Else
Count = Right(!id_user, 3) + 1
x = "USR" + Format(Date, "yyyymmdd") + Right("00" &
Count, 2)
End If
End If
NewNumber = x
End With
End Sub
this code can result USR20180805001, but when i try to add another record to databases, it can not add since the code failed to counter/increase the last 3 digit on the right. hence show error duplicate entry. thank you for the attention.
Related
please look at the code i have below and the image label1 = 2 represents index of winsock
trying to count the index of winsock with the list1 /index values and if non are matched with label2 then remove item
On Error Resume Next
Dim demopacket() As String
Dim X As Integer
For X = List1.ListCount - 1 To 0 Step -1
demopacket() = Split(List1.List(X), "/")
Dim num As Integer
num = num + 1
Debug.Print num
If num = Label1.Caption Then
'Exit For
End If
If Label1.Caption = demopacket(2) Then
Else
List1.RemoveItem X
lstOnline.RemoveItem X
'RemoveUser List1.List(X)
'RemoveUserFromRoom List1.List(X)
Call RemoveUser(demopacket(0))
Call RemoveUserFromRoom(demopacket(0))
Call RoomCount(demopacket(1), False)
End If
'Debug.Print demopacket(0)
'demopacket(0) username
'demopacket(1) roomname
'demopacket(2) index
Next
still removes index users that exist
so again
label1.caption = 2
xxx2x/room1/4 Remove
jas8du2/room1/1
mosdjas/room2/2
jaosjdiasjd/room1/5 Remove
jasidjas92m/room1/8 Remove
I'm trying to read a recordset from SQL database were some field are of type time(n).
When I read a row (recordset.Fields(n)), VBScript stops at this field with a 'multiple step error'.
I tried to set a variable with the recordset, so:
Dim a
Set a = recordset.Fields(specific time column)
I tried to cast the field.
I tried to find any information about this specific type, but I can't find any information about this time structure, besides it contains hour, minute, second and fractional parts.
ReDim iArr(iColumnCount)
While Not objRecordset.EOF
For iColumnIndex = 0 To (iColumnCount-1)
'SQL_FIELDTYPE_TIME is a constant at top of page with value 145
If objRecordset.Fields(iColumnIndex).Type = SQL_FIELDTYPE_TIME Then
'Tried so much over here...
Dim Tme, Str
Set Tme = objRecordset.Fields.Item(iColumnIndex)
iArr(iColumnIndex) = CStr(clDBTime(Tme).Hour)
Set Tme = Nothing
Else
iArr(iColumnIndex) = objRecordset.Fields.Item(iColumnIndex)
End If
If Err.Number <> 0 Then
fLogData("Ophalen data (" + oDB.strDatabaseNaam + ") rij " + _
CStr(objRecordset.AbsolutePosition) + " kolom " + _
CStr(iColumnIndex) + " mislukt: " + Err.Description)
Err.Clear
End If
Next
List.Add i, iArr
i = i + 1
objRecordset.MoveNext 'Next row
Wend
Errors I'm getting:
Object doesn't support this property
Multiple step error
Type mismatch
etc. etc.
Anyone who can help me out how to read the time value from SQL in VBScript?
EDIT: solved! Cost almost 4h trial-error but there's a solution:)
Changed the SQL select statement to:
SELECT COL, COL,... (this are the 'usual' columns),CAST(TIMECOL -this is the time(n) column- as varchar),CAST(TIMECOL2 -this is the time(n) column- as varchar) FROM tabel
And within code: TimeValue(read value - from recordset.fields...) (this is to change varchar back to time)
And .. it just works great!
Edit2: recordset code:
if iResCount > 0 and iColumnCount > 0 then
redim iArr(iColumnCount)
while not objRecordset.EOF
for iColumnIndex = 0 to (iColumnCount-1)
iArr(iColumnIndex) = objRecordset.Fields.Item(iColumnIndex)
if Err.Number <> 0 then
fLogData("Ophalen data ("+oDB.strDatabaseNaam+") rij "+cstr(objRecordset.AbsolutePosition)+ " kolom "+cstr(iColumnIndex)+" mislukt: "+Err.Description)
Err.Clear
end if
next
List.Add i, iArr
i = i + 1
objRecordset.MoveNext 'Next row
wend
set oResult = List'CreateObject("Scripting.Dictionary")
end if
And an example of a function call:
'fGetRecord(DB, Table, Columns, Condition, Field to sort on, Type of sort)
fGetRecord(oHoofdDB,CONST_HDB_STR_TBL_KALENDER,CONST_HDB_STR_KAL_ID+","+CONST_HDB_STR_KAL_NAAM+",CAST("+CONST_HDB_STR_KAL_STARTIJD+" as varchar),CAST("+CONST_HDB_STR_KAL_STOPTIJD+" as varchar)",CONST_HDB_STR_KAL_NAAM+"='"+Naam+"'", "", SORTEER_OPLOPEND)
John
I have to delete data based on its filename. This is what the files look like:
Nostro_BO_FCC_130317.csv [130317 is a created date]
Nostro_BO_FCC_120317.csv
Nostro_BO_FCC_110317.csv
Nostro_BO_FCC_100317.csv
Nostro_BO_FCC_090317.csv
and this is where the data located: D:\BDI\CTS\Data\Nostro\BO FCC\
I have developed VBScript to delete the file but it does not work at all. All I want is to delete the file which below 2 days since current date (13/03/2017).
This is my VBScript:
Dim infolder
Dim ad, intcount, i, str, Postdate, Uploaddate, fileExists, ExpireDate
Dim sql_query, rs, rsU
Dim ObjFSO, objFile, OFile, OfPath, osf, MM, DD
Set ad = CreateObject("ADODB.Connection")
ad.Provider = "sqloledb"
If Len(Month(varDate)) = 1 then
MM = "0" & Month(varDate)
Else
MM = Month(varDate)
End If
If Len(Day(varDate)) = 1 then
DD = "0" & Day(varDate)
Else
DD = Day(varDate)
End If
PostDate = Year(varDate) & MM & DD
Uploaddate = DD & MM & Right(Year(varDate), 2)
ExpireDate = CDate(DD) < Date - 1 & MM & Right(Year(varDate), 2)
ad.CursorLocation = 3
ad.Open propstr
Set osf = CreateObject("Scripting.FileSystemObject")
OfPath = "D:\BDI\CTS\Data\Nostro\BO FCC\"
'this below my logic steven
Set infolder = osf.GetFolder(OfPath)
Set OFile = Nothing
fileExists = True
fullfilename = "Nostro_BO_FCC_"& Uploaddate &".csv"
'create file if not exits and delete if exits then create again
If Not osf.FileExists(OFPath & fullfilename) Then
Set OFile = osf.CreateTextFile(OFPath & fullfilename, True)
Set OFile = Nothing
End If
For Each file In infolder.Files
If DateDiff("d", file.DateCreated, Date) < Date -2 Then
' oFSO.DeleteFile(oFile)
'If osf.FileExists(OfPath & "Nostro_BO_FCC_" & ExpireDate & ".csv") Then
'osf.DeleteFile OfPath & "Nostro_BO_FCC_" & ExpireDate & ".csv"
file.Delete(True)
End If
Next
CDate(DD) < Date -1 & MM & Right(Year(varDate),2) isn't going to do what you apparently expect it to do. I already told you that when answering your previous question where you used a similar construct.
If you want to compare date strings with a < or > operator, the strings must be in a format where string order and date order are identical. That is not the case for your DDMMYY format. Because of that you basically have two options:
Since you have a small number of valid dates you could build reference filenames:
Function dd(s) : dd = Right("00" & s, 2) : End Function
d1 = Date
d2 = d1 - 1
d3 = d1 - 2
fn1 = "Nostro_BO_FCC_"& dd(Day(d1)) & dd(Month(d1)) && Right(Year(d1), 2) &".csv"
fn2 = "Nostro_BO_FCC_"& dd(Day(d2)) & dd(Month(d2)) && Right(Year(d2), 2) &".csv"
fn3 = "Nostro_BO_FCC_"& dd(Day(d3)) & dd(Month(d3)) && Right(Year(d3), 2) &".csv"
and delete all files whose name isn't among them:
For Each f In infolder.Files
If f.Name <> fn1 And f.Name <> fn2 And f.Name <> fn3 Then
f.Delete
End If
Next
A more generic approach is to parse the date from each filename:
a = Split(osf.GetBaseName(f), "_")
ds = a(UBound(a))
d = DateSerial(Mid(ds, 5, 2), Mid(ds, 3, 2), Mid(ds, 1, 2))
and delete all files with a date below your reference date:
refDate = Date - 2
For Each f In infolder.Files
...
If d < refDate Then
f.Delete
End If
Next
Edit: If you want to compare the files' creation date against a reference date you can do that like this:
refDate = Date - 2
For Each f In infolder.Files
If f.DateCreated < refDate Then
f.Delete
End If
Next
I am reading a text file with 5000 strings. Each string contains Date+Time and then 3 values. The delimiter between Date and Time is a space, and then the three values are tab delimited. First string (strData(0)) is just a header, so I do not need that. Last string is just a simple "End".
The below code works, but it takes 1 minute to import into the worksheet! What can I do to improve this, and what is taking time?
Screen updating is off.
'open the file and read the contents
Open strPpName For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'split the data and write into the correct columns
Row = 3
i = 0
For Each wrd In strData()
If i > 0 Then 'first string is only header
tmpData() = Split(wrd, vbTab)
DateString() = Split(tmpData(0), " ")
If DateString(0) <> "End" Then
ActiveSheet.Cells(Row, 5) = DateString(0) 'Date
ActiveSheet.Cells(Row, 6) = DateString(1) 'Time
ActiveSheet.Cells(Row, 2) = tmpData(1) 'Value1
ActiveSheet.Cells(Row, 3) = tmpData(2) 'Value2
ActiveSheet.Cells(Row, 4) = tmpData(3) 'Value3
Row = Row + 1
Else
GoTo Done
End If
End If
i = i + 1
Next wrd
Done:
Try with something like this:
Dim Values(), N, I
N = 100
ReDim Values(6, N)
...
Do While Not EOF(1)
I = I + 1
If I > N Then
N = N + 100
ReDim Preserve Values(6, N)
End If
Values(0, I) = ...
...
Loop
Range("A1:F" & i) = Values
The loop will work with arrays that in VBA are much faster than working with the sheet.
Excel can handle multiple types of delimiters (tab and space) with get data from text. This is what I have from macro recorder
Sub Macro1()
'
' Macro1 Macro
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\jeanno\Documents\random.txt", Destination:=Range("$A$1"))
.CommandType = 0
.Name = "random_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
This will be much faster than string manipulation in VBA.
I think the problem is you might be reading the file in Binary. Try the following approach. I ran 5100+ records and it parsed it in under a second.
Public Sub ReadFileToExcel(filePath As String, rowNum As Long)
'******************************************************************************
' Opens a large TXT File, reads the data until EOF on the Source,
' adds the data in a EXCEL File, based on the row number.
' Arguments:
' ``````````
' 1. The Source File Path - "C:\Users\SO\FileName.Txt" (or) D:\Data.txt
' 2. The Row number you wish to start adding data.
'*******************************************************************************
Dim strIn As String, lineCtr As Long
Dim tmpData, DateString
'Open the SOURCE file for Read.
Open filePath For Input As #1
'Loop the SOURCE till the last line.
Do While Not EOF(1)
'Read one line at a time.
Line Input #1, strIn
lineCtr = lineCtr + 1
If lineCtr <> 1 Then
If InStr(strIn, "END") = 0 Then
tmpData = Split(strIn, vbTab)
DateString = Split(tmpData(0), " ")
ActiveSheet.Cells(rowNum, 5) = DateString(0) 'Date
ActiveSheet.Cells(rowNum, 6) = DateString(1) 'Time
ActiveSheet.Cells(rowNum, 2) = tmpData(1) 'Value1
ActiveSheet.Cells(rowNum, 3) = tmpData(2) 'Value2
ActiveSheet.Cells(rowNum, 4) = tmpData(3) 'Value3
rowNum = rowNum + 1
End If
End If
Loop
Debug.Print "Total number of records - " & lineCtr 'Print the last line
'Close the files.
Close #1
End Sub
Can someone help me with this problem. I have this code but it doesn't work. Something is wrong it says "Sub or Function not define".
Sub Macro1()
'
' Macro1 Macro
'
Dim x As Integer, result As String
x = 2
' 1st row
Do While Cells(x, 4).Value = 1
If Cells(x, 3).Value <= Cells(x, 2).Value And Not Cells(x, 4).Value < Cells(x, 1).Value Then
result = "pass"
Else
result = "fail"
End If
Cell(x, 5).Value = result
x = x + 1
Loop
End Sub
Change Cell to Cells and it will work. Excel just wasn't being helpful enough with that error message. It does however select the text for Cell when you have the editor open and try to run it.
Sub Macro1()
'
' Macro1 Macro
'
Dim x As Integer, result As String
x = 2
' 1st row
Do While Cells(x, 4).Value = 1
If Cells(x, 3).Value <= Cells(x, 2).Value And Not Cells(x, 4).Value < Cells(x, 1).Value Then
result = "pass"
Else
result = "fail"
End If
Cells(x, 5).Value = result
x = x + 1
Loop
End Sub