Read Data from csv file using VB - vb6

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

Related

Excel VBA: Run time error 7: Out of Memory

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

Compare value in 2 excel sheet and sort by descending in VBA

I'd like to use excel 2010 to realize a function to first compare values from 2 different Excel sheets and then sort them based on another column value.
For example:
In sheet 1, I've got:
Name Value
Test 1 100.5
Test 1 200.6
Test 1 300.3
Test 2 100.8
Test 2 200.6
Test 3 200.5
In sheet 2, I've got :
Name
Test 1
Test 1
Test 1
Test 3
what I want to achieve is if the name from sheet 1 is not in sheet 2, delete the whole line in sheet 1 and sort by descending the name based on the column value.
Desired:
Name Value
Test 1 300.3
Test 1 200.6
Test 1 100.5
Test 3 200.5
Here is what I get so far:
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer, j As Integer
Dim lastRow1 As Integer, lastRow2 As Integer
On Error GoTo 0
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastRow1 = ws1.UsedRange.Rows.Count
lastRow2 = ws2.UsedRange.Rows.Count
For i = 2 To lastRow1
For j = 2 To lastRow2
If ws1.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, ws2.Cells(j, 1).Value, ws1.Cells(i, 1).Value, vbTextCompare) < 1 Then
Rows(i).EntireRow.delete
Exit For
End If
End If
Next j
Next i
End Sub
Please suggest and help. thank you very much in advance.
I changed your code so it is working:
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer, j As Integer
Dim lastRow1 As Integer, lastRow2 As Integer
On Error GoTo 0
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row 'last used cell in column A
lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row 'last used cell in column A
Dim same As Boolean
same = False
For i = lastRow1 To 2 Step -1 'bottom to top
For j = 2 To lastRow2
Debug.Print ws1.Cells(i, 1).Value
Debug.Print ws2.Cells(j, 1).Value
If ws1.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
same = True 'set True if match
End If
End If
Next j
If same = False Then 'if no match
Rows(i).EntireRow.Delete
End If
same = False
Next i
'sort
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lastRow1).Sort key1:=Range("A2:A" & lastRow1), order1:=xlAscending, Header:=xlNo, key2:=Range("B2:B" & lastRow1), order2:=xlAscending, Header:=xlNo
End Sub
Still thinking about the rest of the answer, but in advance I would advise you to start at the bottom of the list (so from lastrow to the second row) The reason for this is that you are removing rows which your counter does not take into account. You may also want to look into the MATCH function in Excel to see if a certain value is used in a list instead of going through the whole list.

Crystal report not showing in application

I have a function that i am using to show crystal reports in my application. Everything was fine until yesterday afternoon and now it is showing nothing but a blank window. But it is not giving any error.In crystal report designer it is showing values while previewing. I am using stored procedure to retrieve values from DB. Here is my code
Public Sub ShowReport(ParamArray reportParameters())
On Error GoTo Catch
Dim NTOT As Integer
Dim nCtr As Integer
Dim LoopCount As Integer
Dim ReportPath As String
Open App.Path & "/Reports.txt" For Input As #1
Input #1, ReportPath
Close #1
ReportPath = ReportPath & "\Reports\" & reportParameters(0)
'MsgBox ReportPath
Screen.MousePointer = vbHourglass
With frmReports.Crpt
.Reset
.WindowTop = 0
.WindowLeft = 0
.ReportFileName = ReportPath
'.RetrieveStoredProcParams
For LoopCount = 3 To UBound(reportParameters)
.StoredProcParam(LoopCount - 3) = reportParameters(LoopCount)
Next
.WindowTitle = reportParameters(1)
.ReportTitle = reportParameters(1)
.WindowParentHandle = frmReports.hwnd
.WindowShowSearchBtn = True
.WindowShowPrintSetupBtn = True
.WindowShowRefreshBtn = True
.WindowShowProgressCtls = True
.WindowShowZoomCtl = True
.WindowShowGroupTree = True
.WindowAllowDrillDown = True
.ProgressDialog = True
.PageZoom (100)
.WindowState = crptMaximized
If reportParameters(2) = "P" Then
.Destination = crptToPrinter
Else
.Destination = crptToWindow
End If
.Action = 1
End With
Screen.MousePointer = vbNormal
Exit Sub
Catch:
Screen.MousePointer = vbNormal
End Sub
I am using VB6 and crystal reports version is 8
what is wrong in this code? Can anyone find a solution for this

Copy a particular column from multiple excel files to a single column of another excel file

I am failrly new to VBScript, I want to copy a particular column (say Column C) from multiple excel sheets (Source_1.xlsx, Source_2.xlsx, and Source_3.xlsx). and paste it to Column A of another excel sheet Dest.xlsx. This column should be free from duplicate values. Any help would be appreciated.
Firstly you need to create the excel object, assuming the files are the same, and you use an increasing integer at the end, you can iterate through each excel object. as you iterate through, you can call upon the same column as a const, and copy to a new filename. When you start to have some code, report back and it can be worked on further
for i to x
filename = "scen_"& i & ".xlsx"
copyfilename = "copytohere.xlsx"
'set up the object
for rowstart to rowend
'get contents of x column
'copy contents to copyfilename excel doc
Loop
loop
Thanks
Const xlFilterCopy = 2
Const xlUp = -4162
Const xlDown = -4121
strPathSrc = "C:\Test" ' Source files folder
strMaskSrc = "Source_*.xlsx" ' Source files filter mask
iSheetSrc = 1 ' Sourse sheet index or name
iColSrc = 3 ' Source column index, e. g. 3 for "C"
strPathDst = "C:\Test\Dest.xlsx" ' Destination file
iColDst = 1 ' Destination column index
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetTmp = objWorkBookDst.Worksheets.Add
objSheetTmp.Cells(1, iColDst).Value = "TempHeader"
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
For Each objItem In objItems
Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
Set objSheetSrc = objWorkBookSrc.Sheets(iSheetSrc)
objSheetSrc.Cells(1, iColSrc).Insert xlDown
objSheetSrc.Cells(1, iColSrc).Value = "TempHeader"
Set objRangeSrc = GetRange(iColSrc, objSheetSrc)
If objRangeSrc.Cells.Count > 1 then
nNextRow = GetRange(iColDst, objSheetTmp).Rows.Count + 1
objRangeSrc.AdvancedFilter xlFilterCopy, , objSheetTmp.Cells(nNextRow, iColDst), True
objSheetTmp.Cells(nNextRow, iColDst).Delete xlUp
Set objRangeTmp = GetRange(iColDst, objSheetTmp)
Set objSheetDst = objWorkBookDst.Worksheets.Add
objRangeTmp.AdvancedFilter xlFilterCopy, , objSheetDst.Cells(1, iColDst), True
objSheetTmp.Delete
Set objSheetTmp = objSheetDst
End If
objWorkBookSrc.Close
Next
objSheetTmp.Cells(1, iColDst).Delete xlUp
objExcel.DisplayAlerts = True
Function GetRange(iColumn, objSheet)
With objSheet
Set GetRange = .Range(.Cells(1, iColumn), .Cells(.Cells(.Cells.Rows.Count, iColumn).End(xlUp).Row, iColumn))
End With
End Function

Need to write values in Excel from an array using vbscript

I need to store values from excel into array using vbscript, I then need to write distinct values from this array to some other excel. From the below scipt I am able to write excel values into array and display it in message box, however I need to write it in another excel. I am getting the error- "Type Mismatch 'Join'" at line 31. Could someone please look into it and assist, Thanks in Advance.
Dim MyArray()
Dim UniqValues
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\Read Excel.xls")
objExcel.Visible = True
objExcel.displayalerts = false
i = 1
x = 0
Do Until objExcel.Cells(i, 1).Value = ""
ReDim Preserve MyArray(x)
MyArray(x) = objExcel.Cells(i, 1).Value
i = i + 1
x = x + 1
Loop
Set objExcel2 = CreateObject("Excel.Application")
strPathExcel = "D:\file1.xls"
objExcel2.Workbooks.open strPathExcel
Set oSheet = objExcel2.ActiveWorkbook.Worksheets(1)
oSheet.Cells(1,1).Value = Join(UniqValues)
'WScript.Echo Join(MyArray)
UniqValues = uniqFE(MyArray)
'WScript.Echo Join(UniqValues)
Function uniqFE(fex)
Dim dicTemp : Set dicTemp = CreateObject("Scripting.Dictionary")
Dim xItem
For Each xItem In fex
dicTemp(xItem) = 0
Next
uniqFE = dicTemp.Keys()
End Function
objExcel.Save
objExcel.Quit
Your UniqValues is not initialized wheb you try to Join it:
>> Dim UniqValues
>> X = Join(UniqValues)
>>
Error Number: 13
Error Description: Type mismatch
Call uniqFE() before you assign/display it.

Resources