why now return ....Syntax error
Can i put the Sub rutine in the function? Or better way for this?!
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
Sub Add(s)
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if f_Type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif f_Type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'wei = Split(arrString(i),"$")(0)
Add arrString(i)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Microsoft VBScript compilation error '800a03ea'
Syntax error
/inc_func_projects.asp, line 2592
Sub Add(s)
^
No - you can't put a sub within a function, except in JavaScript or in the server side version called JScript. VBScript and JScript are two completely different languages, however.
You should be doing this...
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'NOTE: Updated the call to reflect comment by sadrasjd...
Add arrString(i, f_Type, dic)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Sub Add(s, type, dic)
'NOTE: ^Updated the parameters to reflect comment by sadrasjd^
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
NOTE: Updated the call to reflect the suggestion made by sadrasjd.
Related
I try to export to Excel with the fpsread plugin, but there really is no information on how, I have searched the manual but they only show me how to do it with .net
Will someone have an idea?
I managed to do it was very simple, but wanting to import the titles was the heaviest, but here I leave the code in case any work
Private Sub CmdImportar_Click()
Call Export_Excel(cdgExcel, sprFacturas)
Call HacerBusqueda
End Sub
Public Sub Export_Excel(cdgExcel As CommonDialog, Spread As fpSpread)
Dim Header() As String
Dim I As Integer
Dim j As Integer
Dim x As Integer
With cdgExcel
.CancelError = False
.InitDir = "C:/:"
.Filter = "Excel(*.xls)|*.xls"
.ShowSave
If .filename <> "" Then
Spread.Redraw = False
For I = 1 To Spread.ColHeaderRows
ReDim Header(Spread.MaxCols) As String
Spread.Row = SpreadHeader + (I - 1)
For j = 1 To Spread.MaxCols
Spread.Col = j
Header(j) = Spread.Text & ""
Next j
Spread.MaxRows = Spread.MaxRows + 1
Spread.Row = I
Spread.Action = ActionInsertRow
For j = 1 To Spread.MaxCols
Spread.Col = j
Spread.CellType = Spread.CellType
Spread.TypeHAlign = Spread.TypeHAlign
Spread.TypeVAlign = Spread.TypeVAlign
Spread.Text = Header(j) & ""
Next j
Next I
x = Spread.ExportToExcel(.filename, "Sheet1", "")
For I = 1 To Spread.ColHeaderRows
Spread.Row = 1
Spread.Action = ActionDeleteRow
Next I
If x = True Then
MsgBox .filename & vbNewLine & "Se ha Importado el archivo", vbInformation, "Resultado"
Else
MsgBox "No se ha podido exportar el archivo", vbCritical, "Error"
End If
End If
End With
End Sub
Kind of new to VBS. I'm trying to count the fields in the file and have this code.
Col()
Function Col()
Const FSpec = "C:\test.txt"
Const del = ","
dim fs : Set fs = CreateObject("Scripting.FileSystemObject")
dim f : Set f = fs.OpenTextFile(FSpec, 1)
Dim L, C
Do Until f.AtEndOfStream
L = f.ReadLine()
C = UBound(Split(L, del))
C = C +1
WScript.Echo "Items:", C
Loop
f.Close
End Function
It works however, I don't want to count the delim inside " ".
Here's file content:
1,"2,999",3
So basically, I'm getting 4 items for now but I wanted to get 3. Kind of stuck here.
For an example of my second suggestion, a very simple example could be something like this. Not saying it is perfect, but it illustrates the idea:
Dim WeAreInsideQuotes 'global flag
Function RemoveQuotedCommas(ByVal line)
Dim i
Dim result
Dim current
For i = 1 To Len(line)
current = Mid(line, i, 1) 'examine character
'check if we encountered a quote
If current = Chr(34) Then
WeAreInsideQuotes = Not WeAreInsideQuotes 'toggle flag
End If
'process the character
If Not (current = Chr(44) And WeAreInsideQuotes) Then 'skip if comma and insode quotes
result = result & current
End If
Next
RemoveQuotedCommas = result
End Function
I am trying to pass folder location as variable to a VBScript which has array to consume the location as a parameter. I don't know how to pass it, could some one please help me?
I am trying to pass following location as a variable "C:\New","C:\New1" to the below code, the script is working fine when I directly give the location, but when I tired to pass it as variable it is not working.
Code given below:
Set oParameters = WScript.Arguments
folderlocation = oParameters(0)
Dim folderarray
Dim WshShell, oExec
Dim wow()
Set objShell = CreateObject("WScript.Shell")
Dim oAPI, oBag
Dim fso, folder, file
Dim searchFileName, renameFileTo, day
Dim i
folderarray = Array(folderlocation)
ii = 0
day = WeekDay(Now())
If day = 3 Then
aa = UBound(folderarray)
f = 0
j = 0
x = 0
Y = 0
For i = 0 To aa
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderarray(i))
For Each file In folder.Files
If InStr(file.Name, name) = 1 Then
ii = 1
strid = file.Name
Set re = New RegExp
re.Pattern = ".*myfile.*"
If re.Test( strid ) Then
'msgbox "File exist and the file name is """ & strid & """"
x = x+1
Else
'msgbox "file not found"
End If
Set re = Nothing
End If
Next
If x = 0 Then
ReDim Preserve wow(f)
wow(f) = folderarray(i)
f = f+1
j = j+1
Else
x = 0
End If
Next
End If
If J > 0 Then
ReDim Preserve wow(f-1)
value = Join(wow, ",")
MsgBox "Files not found in the following location(s) :" & value
Else
MsgBox "fine"
End If
To fill an array from a list of arguments you'd call the script like this:
your.vbs "C:\New" "C:\New1"
and fill the array in your.vbs like this:
size = WScript.Arguments.Unnamed.Count - 1
ReDim folderarray(size)
For i = 0 To size
folderarray(i) = WScript.Arguments.Unnamed.Item(i)
Next
If for some reason you must pass the folder list as a single argument you'd call the script like this:
your.vbs "C:\New,C:\New1"
and populate the array in your.vbs like this:
folderarray = Split(WScript.Arguments.Unnamed.Item(0), ",")
I would appreciate if anybody can help me with this issue I am having. Basically, the VBA is a search function that enables the user to search part of or the entire name of the job, from a job database.
However, it results in "Runtime error 7: Out of Memory." This happens only on my Macbook, and does not happen on a Windows computer. Upon clicking "debug", it brought me to this line of code:
`If scd.Cells(i, j) Like "*" & Search & "*" Then
please help! Thank you!
The rest of the code is below:
Option Compare Text
Sub SearchClientRecord()
Dim Search As String
Dim Finalrow As Integer
Dim SearchFinalRow As Integer
Dim i As Integer
Dim scs As Worksheet
Dim scd As Worksheet
Set scs = Sheets("Client Search")
Set scd = Sheets("Client Database")
scs.Range("C19:S1018").ClearContents
Search = scs.Range("C12")
Finalrow = scd.Range("D100000").End(xlUp).Row
SearchFinalRow = scs.Range("D100000").End(xlUp).Row
For j = 3 To 19
For i = 19 To Finalrow
If scd.Cells(i, j) Like "*" & Search & "*" Then
scd.Range(scd.Cells(i, 3), scd.Cells(i, 19)).Copy
scs.Range("C100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
Next j
scs.Range("C19:S1018").Select
scs.Range("$C$18:$S$1009").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6 _
, 7), Header:=xlYes
Call Border
Columns("C:S").HorizontalAlignment = xlCenter
End Sub
I created an alternate function called "aLike" below.
In your code you would use it by saying: If aLike("*" & Search & "*",scd.Cells(i, j)) Then
I can't guarantee it works exactly the same way, but I would be interested to see if the Mac can process this function better than "like".
Function aLike(asterixString As Variant, matchString As Variant, Optional MatchCaseBoolean As Boolean) As Boolean
Dim aStr As Variant, mStr As Variant, aStrList As New Collection
Dim i As Long, aPart As Variant, mPart As Variant, TempInt As Long, aStart As Boolean, aEnd As Boolean
aStr = asterixString: mStr = matchString
If Not MatchCaseBoolean Then aStr = StrConv(aStr, vbLowerCase): mStr = StrConv(mStr, vbLowerCase)
' Get rid of excess asterix's
While InStr(aStr, "**") > 0
aStr = Replace(aStr, "**", "*")
Wend
' Deal with trivial case
If aStr = mStr Then aLike = True: GoTo EndFunction
If aStr = "*" Then aLike = True: GoTo EndFunction
If Len(aStr) = 0 Then aLike = False: GoTo EndFunction
' Convert to list
aStart = Left(aStr, 1) = "*": If aStart Then aStr = Right(aStr, Len(aStr) - 1)
aEnd = Right(aStr, 1) = "*": If aEnd Then aStr = Left(aStr, Len(aStr) - 1)
aLike_Parts aStr, aStrList
' Check beginning
If Not aStart Then
aPart = aStrList.Item(1)
If Not (aPart = Left(mStr, Len(aPart))) Then aLike = False: GoTo EndFunction
End If
' Check end
If Not aEnd Then
aPart = aStrList.Item(aStrList.Count)
If Not (aPart = Right(mStr, Len(aPart))) Then aLike = False: GoTo EndFunction
End If
' Check parts
mPart = mStr
For i = 1 To aStrList.Count
aPart = aStrList.Item(i): TempInt = InStr(mPart, aPart)
If TempInt = 0 Then aLike = False: GoTo EndFunction
mPart = Right(mPart, Len(mPart) - TempInt - Len(aPart) + 1)
If Len(mPart) = 0 And i < aStrList.Count Then aLike = False: GoTo EndFunction
Next i
aLike = True
EndFunction:
Set aStrList = Nothing
End Function
Function aLike_Parts(Str As Variant, StrList As Collection) As Variant
Dim Char As String, wPart As String
For i = 1 To Len(Str)
Char = Mid(Str, i, 1)
If Char = "*" Then
StrList.Add wPart: wPart = ""
Else
wPart = wPart & Char
End If
Next i
If Len(wPart) > 0 Then StrList.Add wPart
End Function
Good Luck!
#Alex P , now .find is NOT more efficient, for example :
Option Explicit
Option Compare Text
Sub SearchClientRecord()
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim Search As String
Dim Finalrow As Long
Dim SearchFinalRow As Long
Dim i&, j&
Dim scs As Worksheet
Dim scd As Worksheet
Dim DATA() As Variant
Dim Range_to_Copy As Range
Set scs = Sheets("Client Search")
Set scd = Sheets("Client Database")
With scd
Finalrow = .Range("D100000").End(xlUp).Row
DATA = .Range(.Cells(19, 3), .Cells(Finalrow, 19)).Value2
End With
With scs
.Range("C19:S1018").ClearContents
Search = .Range("C12").Value
SearchFinalRow = .Range("D100000").End(xlUp).Row
End With
With scd
For j = 3 To 19
For i = 19 To Finalrow
If InStr(DATA(i, j), Search) > 0 Then
'If scd.Cells(i, j) Like "*" & Search & "*" Then
If Not Range_to_Copy Is Nothing Then
Set Range_to_Copy = Union(Range_to_Copy, .Range(.Cells(i, 3), .Cells(i, 19)))
'scd.Range(scd.Cells(i, 3), scd.Cells(i, 19)).Copy
'scs.Range("C100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
Else
Set Range_to_Copy = .Range(.Cells(i, 3), .Cells(i, 19))
End If
End If
Next i
Next j
End With 'scd
Erase DATA
With scs
Range_to_Copy.Copy _
Destination:=.Range("C100000").End(xlUp).Offset(1, 0) '.PasteSpecial xlPasteFormulasAndNumberFormats
.Range("C19:S1018").Select 'this line might be superflous
.Range("$C$18:$S$1009").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
End With
Call Border
Columns("C:S").HorizontalAlignment = xlCenter 'on wich worksheet ??
Set Range_to_Copy = Nothing
Set scs = Nothing
Set scd = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
This is the code i wrote in order to First open a csv file as excel, then find the required three columns, n then read data from them n save the data into another variables showing them in textbox. As about the csv file, it contains many columns out of which my focus is on only 3 columns under title ID, L, Lg.
Problem is Excel doesnt actually open but Excel.exe process runs in task manager.
But by this point its not the compile error; Compile error comes at 'Next' Statement. It says Compile Error: Next without For!!!!
I am Confused with this one. Please help me with this one, Thanks in Advance.
Private Sub cmdFind_Click()
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
Dim X As Double, Y As Double, FleetID As String
Dim F As String, FCol As Integer, LCol As Integer, LgCol As Integer, Srno As Integer, I As Integer
Dim xlWbook As Workbook
Dim xlSht As Excel.Worksheet
Set xlWbook = xlApp.Workbooks.Open("C:\Users\saurabhvyas\Desktop\test VB2\testfile.csv")
xlApp.Visible = True
Set xlSht = xlWbook.Worksheets("sheet1")
For I = 1 To 8 Step 1
If xlSht.Cells(I, 1).Value = "ID" Then
FCol = I
Else
If xlSht.Cells(I, 1).Value = "L" Then
LCol = I
Else
If xlSht.Cells(I, 1).Value = "Lg" Then
LgCol = I
End If
Next I
Set Srno = 2
Do
If xlSht.Cells(FCol, Srno).Value = Str$(txtF.Text) Then
Set X = xlSht.Cells(LCol, Srno).Value
Set Y = xlSht.Cells(LgCol, Srno).Value
End If
Srno = Srno + 1
Loop While xlSht.Cells(FCol, Srno).Value = vbNullString
txtL.Text = Str$(X)
txtLg.Text = Str$(Y)
xlWbook.Close
xlApp.Quit
Excel.Application.Close
Set xlSht = Nothing
Set xlWbook = Nothing
Set xlApp = Nothing
End Sub
You can open CSV format text files and operate on them using ADO with the Jet Provider's Text IISAM. Much less clunky than automating Excel. Or you can read the lines as text and Split() them on commas.
What you're doing does open Excel, but you haven't asked Excel to be visible... though I have no idea why you'd want that.
What are you really trying to do?
As for your compile error, that's because you are missing some End Ifs.
Write it as:
For I = 1 To 8 Step 1
If xlSht.Cells(I, 1).Value = "ID" Then
FCol = I
Else
If xlSht.Cells(I, 1).Value = "L" Then
LCol = I
Else
If xlSht.Cells(I, 1).Value = "Lg" Then
LgCol = I
End If
End If
End If
Next I
Or as:
For I = 1 To 8 Step 1
If xlSht.Cells(I, 1).Value = "ID" Then
FCol = I
ElseIf xlSht.Cells(I, 1).Value = "L" Then
LCol = I
ElseIf xlSht.Cells(I, 1).Value = "Lg" Then
LgCol = I
End If
Next I