I have a CSV file that will parse and put it to array. Note this is a big file.My questions are this how can i compute an Array in Vb6? Is it possible to have a computation in Array?
to read in a file and it in an array you can do as follows:
'1 form with
' 1 command button: name=Command1
Option Explicit
Private Sub Command1_Click()
Dim lngLine As Long
Dim intFile As Integer
Dim strFile As String
Dim strData As String
Dim strLine() As String
'select file
strFile = "c:\temp\file.txt"
'read file
intFile = FreeFile
Open strFile For Input As #intFile
strData = Input(LOF(intFile), #intFile)
Close #intFile
'put into array
strLine = Split(strData, vbCrLf)
'loop through complete array and print each element
For lngLine = 0 To UBound(strLine)
Print strLine(lngLine)
Next lngLine
End Sub
this will read in the file, put it into an array (each line with its own element), and then loop through the whole array to print each line/element on the form
[EDIT]
below is an example how to substract items from an array from corresponding items from another array:
Private Sub Command1_Click()
Dim lngIndex As Long
Dim lngA(7) As Long
Dim lngB(7) As Long
'fill the arrays
For lngIndex = 0 To UBound(lngA)
lngA(lngIndex) = lngIndex + 1
Next lngIndex
For lngIndex = 0 To UBound(lngA)
lngB(lngIndex) = (lngIndex + 1) ^ 2
Next lngIndex
'substract array a from array b
For lngIndex = 0 To UBound(lngB)
lngB(lngIndex) = lngB(lngIndex) - lngA(lngIndex)
Next lngIndex
'print arrays
For lngIndex = 0 To UBound(lngA)
Print CStr(lngA(lngIndex)) & " | " & CStr(lngB(lngIndex))
Next lngIndex
End Sub
Related
Function ArrayRemoveDups(MyArray As Variant) As Variant
Dim nFirst As Long, nLast As Long, i As Long
Dim item As String
' Hello I am trying to remove duplicates from an array as well as ignore blanks. But when i insert blanks inbetween the cells there will be an error
Dim arrTemp() As String
Dim Coll As New Collection
'Get First and Last Array Positions
nFirst = LBound(MyArray)
nLast = UBound(MyArray)
ReDim arrTemp(nFirst To nLast)
'Convert Array to String
For i = nFirst To nLast
arrTemp(i) = CStr(MyArray(i))
Next i
'Populate Temporary Collection
On Error Resume Next
For i = nFirst To nLast
Coll.Add arrTemp(i), arrTemp(i)
Next i
Err.Clear
On Error GoTo 0
'Resize Array
nLast = Coll.Count + nFirst - 1
ReDim arrTemp(nFirst To nLast)
'Populate Array
For i = nFirst To nLast
arrTemp(i) = Coll(i - nFirst + 1)
Next i
'Output Array
ArrayRemoveDups = arrTemp
End Function
Sub ArrTest()
Dim WorkingWS As Worksheet
Set WorkingWS = ActiveSheet
Dim LastActiveCellColumn As Long
LastActiveCellColumn = WorkingWS.UsedRange.Columns.Count
MsgBox LastActiveCellColumn
Dim WorkingRng As Range
Dim strNames(10000) As String
Dim outputArray() As String
Dim i As Long
Dim item As Variant
Dim a As Long
Dim B As Long
a = 0
For Each WorkingRng In WorkingWS.Range(Cells(1, 1), Cells(1, LastActiveCellColumn))
strNames(a) = WorkingRng
a = a + 1
Next
outputArray = ArrayRemoveDups(strNames)
'Output values to Immediate Window (CTRL + G)
a = 0
Do While a < LastActiveCellColumn
If Not outputArray(a) = "" Then
MsgBox outputArray(a)
'carry out action here
End If
a = a + 1
Loop
End Sub
Assigning word document lines of text to an array to then print into an excel column. I want to print each item in array to it's own cell.
Currently, all the items are storying correctly into the array, but it's only printing the first item over and over Action
Code:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
Dim i As Long
i = 0
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
ReDim Preserve arr(i)
arr(i) = wPara.Range
End If
i = i + 1
Next wPara
For i = LBound(arr) To UBound(arr)
[a1].Resize(UBound(arr) + 1) = arr
Next i
End Sub
EDIT: Need to separate each block of text separated by a space (outlined in blue) to this
Create a 2D array with one column and load that:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
ReDim arr(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim i As Long
i = 1
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
arr(i, 1) = wPara.Range
i = i + 1
End If
Next wPara
[a1].Resize(UBound(arr) + 1) = arr
End Sub
Copy Word Paragraphs to Excel Cells Using an Array
The number of rows of the array is wDoc.Paragraphs.Count which may differ from r (the 'actual count') hence you have to use r with Resize, and not wDoc.Paragraphs.Count or UBound(Data, 1).
Don't forget to Close the Document and Quit the App.
The first solution is early-bound and needs the library reference. When using it, just use
Set wApp = New Word.Application.
The second solution is late-bound and doesn't need the library reference. Also, it has been 'stripped off' the document and application variables (not necessary, you can declare them As Object).
Option Explicit
' e.g. Tools>References>Microsoft Word 16.0 Object Library
Sub ParaCopy()
Const FilePath As String = "J:\Data Dictionary.docx"
Dim wApp As Word.Application: Set wApp = Set wApp = New Word.Application
Dim wDoc As Word.Document: Set wDoc = wApp.Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim wPara As Word.Paragraph
Dim r As Long
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
wDoc.Close False
wApp.Quit
[a1].Resize(r) = Data
End Sub
Sub ParaCopyNoReference()
Const FilePath As String = "J:\Data Dictionary.docx"
With CreateObject("Word.Application")
With .Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To .Paragraphs.Count, 1 To 1)
Dim wPara As Object
Dim r As Long
For Each wPara In .Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
.Close False
End With
.Quit
End With
[a1].Resize(r) = Data
End Sub
so what I need to do is fill an array using an InputBox, then but that in an array, sort it alphabetically and then output it to the current word document. I have it almost most complete, the issue is it is only outputting the last word to the document. Im guessing my loop is wrong but I cannot find VBA documentation to do this to save my life. Thank you
Option Explicit
This is the main sub that declares the array
Sub Main()
Dim ListArr() As String
ListArr = Get_Input_List()
Call Bubble_Sort_Ascending(ListArr)
Call Output_List_To_Document(ListArr)
End Sub
Function to get input and fill array
Function Get_Input_List() As String()
Dim list As String
list = InputBox("Please enter words to sort separated with a comma and no spaces", "Words")
Get_Input_List = Split(list, ",")
End Function
Sorts the array alphabetically
Sub Bubble_Sort_Ascending(listNewArray() As String)
Dim SrtTemp As Variant
Dim inputWord As Variant
Dim i As Long
Dim j As Long
'Alphabetize Sheet Names in Array List
For i = LBound(listNewArray) To UBound(listNewArray)
For j = i To UBound(listNewArray)
If listNewArray(i) > listNewArray(j) Then
SrtTemp = listNewArray(j)
listNewArray(j) = listNewArray(i)
listNewArray(i) = SrtTemp
End If
Next j
Next i
End Sub
This is the problem, I cannot output the whole array to the word document. I have found plenty of documentation on how to do this into an excel spreadsheet but almost nothing for word.
Sub Output_List_To_Document(newListArray() As String)
Dim inputWord As Variant
Dim i As Long
Dim j As Long
For i = LBound(newListArray) To UBound(newListArray)
For j = i To UBound(newListArray)
For Each inputWord In newListArray
ActiveDocument.Range = inputWord & vbCrLf
Next
Next j
Next i
End Sub
You're over-writing ActiveDocument.Range each time through the loop. If you want to append to the end of it, you need to collapse the range to it's ending position:
Sub Output_List_To_Document(newListArray() As String)
Dim inputWord As Variant
Dim i As Long
Dim j As Long
Dim insertPos As Range
Set insertPos = ActiveDocument.Range
For i = LBound(newListArray) To UBound(newListArray)
For j = i To UBound(newListArray)
For Each inputWord In newListArray
insertPos.Collapse wdCollapseEnd
insertPos = inputWord & vbCrLf
Next
Next j
Next i
End Sub
Note - It isn't clear why you're looping through the array with 3 nested loops. If you only need to write each word once, I suspect you're really looking for something more like this:
Sub Output_List_To_Document(newListArray() As String)
Dim insertPos As Range
Set insertPos = ActiveDocument.Range
Dim inputWord As Variant
For Each inputWord In newListArray
insertPos.Collapse wdCollapseEnd 'Value 0, Can ignore writing it as well
insertPos = inputWord & vbCrLf
Next
End Sub
I'm lost, I try to fill arrays and receive a type mismatch
I'm trying to fill 4 arrays from one file
There is 500 lines in the text document each holding 4 different types of data separated by ","
The .txt file format example --->
pear, apple, grape, orange
apple, pear, orange, grape
ect...
Here is my code:
Private Sub CmdRun_Click()
Dim ticketid(500) As Variant
Dim theatreid(500) As Variant
Dim ticketamount(500) As Variant
Dim paymethod(500) As Variant
Open "C:\Users\Dylaan\Desktop\School Solution\tickets.txt" For Input As #1
Do While Not EOF(1)
Input #1, ticketid(), theatreid(), ticketamount(), paymethod()
lstticketid.AddItem ticketid()
lsttheatreid.AddItem theatreid()
lstticketamount.AddItem ticketamount()
lstmethod.AddItem paymethod()
Exit Do
Loop
Close #1
End Sub
Why?
take a look on this:
Private Sub CmdRun_Click()
Dim ticketid(500) As Variant
Dim theatreid(500) As Variant
Dim ticketamount(500) As Variant
Dim paymethod(500) As Variant
dim ix as integer
Open "C:\Users\Dylaan\Desktop\School Solution\tickets.txt" For Input As #1
ix = 0
Do While Not EOF(1)
Input #1, ticketid(ix), theatreid(ix), ticketamount(ix), paymethod(ix)
lstticketid.AddItem ticketid(ix)
lsttheatreid.AddItem theatreid(ix)
lstticketamount.AddItem ticketamount(ix)
lstmethod.AddItem paymethod(ix)
ix = ix + 1
Loop
Close #1
End Sub
And of course you should consider to use
freefile (to get a filehandle)
and also the possibility that there are MORE records than expected ...
Set fso = CreateObject("Scripting.FileSystemObject")
Set srcfile = fso.GetFile("c:\myfile.txt")
If err.number = 0 then Set TS = srcFile.OpenAsTextStream(1, 0)
Src=ts.readall
Arr1=Split(Src, vbcrlf)
For Each thing in Arr1
Arr2=Split(thing, ",")
For Each thing2 in Arr2
msgbox thing2
Next
Next
This is vbscript but will work in VB6. We are using the split command.
Some comments on your code:
You don't need to declare those arrays as variants, you can declare them as arrays of strings.
As the file is just 500 lines you can read it in at once.
Your real problem is the input command: It can't read in arrays at once.
The same applies to the listbox: You can't add an array at once.
With all that applied have a look at the following test project:
'1 form with:
' 1 command button : name=Command1
' 4 listbox controls : name=List1 name=List2 name=List3 name=List4
Option Explicit
Private Sub Command1_Click()
Dim strData As String
strData = ReadFile("c:\temp\file.txt")
ShowData strData
End Sub
Private Sub Form_Resize()
Dim sngWidth As Single
Dim sngCmdHeight As Single
Dim sngLstWidth As Single, sngLstHeight As Single
sngWidth = ScaleWidth
sngCmdHeight = 315
sngLstHeight = ScaleHeight - sngCmdHeight
sngLstWidth = sngWidth / 4
List1.Move 0, 0, sngLstWidth, sngLstHeight
List2.Move sngLstWidth, 0, sngLstWidth, sngLstHeight
List3.Move 2 * sngLstWidth, 0, sngLstWidth, sngLstHeight
List4.Move 3 * sngLstWidth, 0, sngLstWidth, sngLstHeight
Command1.Move 0, sngLstHeight, sngWidth, sngCmdHeight
End Sub
Private Function ReadFile(strFile As String) As String
Dim intFile As Integer
Dim strData As String
intFile = FreeFile
Open strFile For Input As #intFile
strData = Input(LOF(intFile), #intFile)
Close #intFile
ReadFile = strData
End Function
Private Sub ShowData(strData As String)
Dim lngLine As Long
Dim strLine() As String
Dim strPart() As String
strLine = Split(strData, vbCrLf)
For lngLine = 0 To UBound(strLine)
strPart = Split(strLine(lngLine), ",")
If UBound(strPart) = 3 Then
List1.AddItem strPart(0)
List2.AddItem strPart(1)
List3.AddItem strPart(2)
List4.AddItem strPart(3)
Else
'not the correct number of items
End If
Next lngLine
End Sub
When you click on Command1 it will read in the textfile from c:\temp\file.txt
After that it will split the data to form an array of lines, loop over all lines, split each line into part, and show the parts in the listboxes, if there are exactly 4 parts on a line.
how do i filter an array using another array vb6
Edit
given an array A, remove all elements in array B from array A
In that case, I'd just sort one array, then iterate through the second, deleting things from the first array if they are found. This algorithm seems to take O(n lg n) and does what you want it to do.
Assuming they are integer arrays:
Dim FilteredArray() As Integer
Dim X as Long
Dim Y as Long
Dim Z as Long
Dim bDupe as Boolean
Z = -1
For X = 0 to UBound(A)
bDupe = False
For Y = 0 to UBound(B)
If A(X) = B(Y) Then
bDupe = True
Exit For
End If
Next
If Not bDupe Then
Z = Z + 1
ReDim Preserve FilteredArray(Z)
FilteredArray(Z) = A(X)
End If
Next
Try something like this
Option Explicit
Private Sub Form_Load()
Dim vElem As Variant
For Each vElem In SubstractArray(Array("aa", "b", "test"), Array("c", "aa", "test"))
Debug.Print vElem
Next
End Sub
Private Function SubstractArray(arrSrc As Variant, arrBy As Variant) As Variant
Dim cIndex As Collection
Dim vElem As Variant
Dim vRetVal As Variant
Dim lIdx As Long
If UBound(arrSrc) < LBound(arrSrc) Then
Exit Function
End If
'--- build index collection
Set cIndex = New Collection
For Each vElem In arrBy
cIndex.Add vElem, "#" & vElem
Next
'--- allocate output array
lIdx = LBound(arrSrc)
ReDim vRetVal(lIdx To UBound(arrSrc)) As Variant
'--- iterate source and seek in index
For Each vElem In arrSrc
On Error Resume Next
IsObject cIndex("#" & vElem)
If Err.Number <> 0 Then
vRetVal(lIdx) = vElem
lIdx = lIdx + 1
End If
On Error GoTo 0
Next
'--- shrink output array
If lIdx = LBound(vRetVal) Then
vRetVal = Split(vbNullString)
Else
ReDim Preserve vRetVal(0 To lIdx - 1) As Variant
End If
SubstractArray = vRetVal
End Function
i have found the answer myself, thanks for all who contributed
Function FilterArray(ByVal Source As String, ByVal Search As String, Optional _
ByVal Keep As Boolean = True) As String
Dim i As Long
Dim SearchArray() As String
Dim iSearchLower As Long
Dim iSearchUpper As Long
If LenB(Source) <> 0 And LenB(Search) <> 0 Then
SearchArray = Split(Search, " ")
Else
FilterArray = Source
Exit Function
End If
iSearchLower = LBound(SearchArray)
iSearchUpper = UBound(SearchArray)
For i = iSearchLower To iSearchUpper
DoEvents
Source = Join(Filter(Split(Source, " "), SearchArray(i), Keep, _
vbTextCompare), " ")
Next i
FilterArray = Source
End Function