Excel Automation-With Visual Basic 6

[Esmael]

[left]
Hi to all,

/*****************************/
OS-WIn XP SP2
VB6 SP6
/*****************************/

Is their anyone who can help me with this:

Source code written on VB6.

Description:
When this procedure is fired. It will read and seach from an excel file and locate the INPUTTED text as search item. Searching will start from Column 'L' to 'Z' and from rows 'L6' to 'L2915'

(this is my old program in vb6 and due to business i cant focus on this)
This module is already working... problem is it eats a lot of resources ...
can anyone pls tell me how to re-write this code...?


any help is appreciated...


Thank you!

Private Sub Cmd_Click(Index As Integer)
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlBook2 As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim wksht As New Worksheet '*Ref to worksheet
Dim wksht2 As New Worksheet '*Ref to worksheet

Dim Var1 As String 'Holds the search string
Dim ctr As Long, Duplicate As Long, Counter As Long: Counter = 6
Dim c As Object, Bilang As Long, Bilang2 As Long, AddL As Currency: AddL = 0
Dim AddL2 As Currency: AddL2 = 0 'Monthly Dep.
Dim AddL3 As Currency: AddL3 = 0 'Lease Payable
Dim AddL4 As Currency: AddL4 = 0 'Interest
Dim BlnL6L9 As Boolean, OK_Item As Boolean 'Row six to nine
BlnL6L9 = False: OK_Item = False
Dim RowCntr As Long: RowCntr = 6
Dim IsNextCol As Boolean: IsNextCol = False
Dim Alphabet As Integer
Dim Letters As Integer
Dim A

On Error GoTo ErrDisplay

Select Case Index
Case 0 '*Display
Screen.MousePointer = vbHourglass
If ((txtLN.Enabled = True Or txtLN.Enabled = False) And Len(txtLN.Text) = 0) Then 'Or ((CboGroups.Enabled = True Or CboGroups.Enabled = False) And Len(CboGroups.Text) = 0) Then
If CboGroups.Enabled = False Then
MsgBox "Input Required.", vbInformation
Screen.MousePointer = vbDefault
Exit Sub
End If
End If


Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Open("C:\Fix assets\Asset Managment (2) (2) 10 03 2006.xls")


If CboGroups.Enabled = True Then _
If CboGroups.Text = "ALL" Then xlApp.Visible = True: GoTo EndShow

Set xlSheet = xlApp.Worksheets("summary")
xlSheet.Visible = xlSheetVisible


'*********************************Groups
If Opt(0).Value = True Then 'Groups 'where =trim(CboGroups.text)


'Copy Worksheet Summary
xlApp.Worksheets.Copy xlApp.Worksheets("summary")
Set wksht = xlApp.Worksheets("summary (2)") 'xlBook.Worksheets(1)
wksht.Activate

Var1 = Trim(CboGroups.Text)
Set foundcell = xlBook.Worksheets("summary").Columns("L").Find(Var 1)
'If in column L did not find then move to other columns (M-Z)
If foundcell Is Nothing Then
For Letters = 77 To 90
Set foundcell = xlBook.Worksheets("summary").Columns(Chr$(Letters) ).Find(Var1)
If Not foundcell Is Nothing Then Exit For
Next Letters
End If
'If not found from columns(A-Z)
If foundcell Is Nothing Then
MsgBox "Not found.", vbInformation
Screen.MousePointer = vbDefault
Exit Sub
End If

Duplicate = 0 'Set counter to 0 trace how many duplicates
Counter = 6 'Rows indicators/Count ...starts with rows 6
Bilang2 = 1 'Counts 1 to 4 rows


Dim blnFirst As Boolean: blnFirst = True
Dim blnUna As Boolean
Dim Merun As Boolean

'*********************************** EXCEL TEMPLATE
Set xlBook2 = xlApp.Workbooks.Open(App.Path & "\Asset Managment Template.xls")
'*********************************** EXCEL TEMPLATE
'***************************************
Set wksht2 = xlBook2.Worksheets("summary")
wksht2.Activate

xlApp.DisplayAlerts = False
xlBook2.Saved = True
'***************************************
For Each c In wksht.Range("L6:L2915") 'Find range and instance
Screen.MousePointer = vbHourglass

If Trim(CStr(wksht.Range("K" & Counter))) = "Group" Then 'And OK_Item = True Then
If Trim(CStr(wksht.Range("K" & Counter))) = "Group" Then 'And Not IsNull(Trim(CStr(wksht.Range("L" & Counter)))) Then

For Alphabet = 76 To 90 'L-Z
If Trim(CStr(wksht.Range(Chr$(Alphabet) & Counter))) = Trim(Var1) Then _
Merun = True
Next Alphabet

If Merun = True Then
Duplicate = Duplicate + 1
Bilang = 7 '9
BlnL6L9 = True
wksht.Range("A" & (Counter - 4)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1

wksht.Range("A" & (Counter - 3)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1

wksht.Range("A" & (Counter - 2)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1

wksht.Range("A" & (Counter - 1)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1

wksht.Range("A" & (Counter)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1

'************************************************* *****************
wksht.Range("A" & (Counter + 1)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1

wksht.Range("A" & (Counter + 2)).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1
'************************************************* *****************
End If
Bilang2 = 1
Merun = False
End If

End If
Counter = Counter + 1
Screen.MousePointer = vbDefault
Next c

'************************************************* **************************************
Counter = 0
Bilang = 0
Bilang2 = 0

xlApp.Visible = True


Set xlSheet = xlBook.Worksheets("summary")
xlSheet.Visible = xlSheetHidden


ElseIf Opt(1).Value = True Then 'Lease Nos. 'where =trim(TxtLN.text)
'**********************************Lease Nos.

'Copy Worksheet Summary
xlApp.Worksheets.Copy xlApp.Worksheets("summary")
Set wksht = xlApp.Worksheets("summary (2)") 'xlBook.Worksheets(1)
wksht.Activate

'Set Var1 = xlBook.Worksheets("summary").Range("c6")
Var1 = UCase(Trim(txtLN.Text))
Set foundcell = xlBook.Worksheets("summary").Columns("C").Find(Var 1)

If foundcell Is Nothing Then
MsgBox "Not found.", vbInformation
Screen.MousePointer = vbDefault
Exit Sub
End If

Dim HasCaption As Boolean: HasCaption = True
Duplicate = 0 'Set counter to 0
Counter = 6 'Rows indicators/Count
Bilang2 = 1 'Counts 1 to 4 rows

'*********************************** EXCEL TEMPLATE
Set xlBook2 = xlApp.Workbooks.Open(App.Path & "\Asset Managment Template.xls")
'*********************************** EXCEL TEMPLATE
'***************************************
Set wksht2 = xlBook2.Worksheets("summary")
wksht2.Activate

xlApp.DisplayAlerts = False
xlBook2.Saved = True
'***************************************

For Alphabet = 76 To 90 'L-Z

For Each c In wksht.Range("C6:C2915") 'Find range and instance
Screen.MousePointer = vbHourglass

If c.Value = Var1 Then
Duplicate = Duplicate + 1
Bilang = 7
Bilang2 = 1
AddL = AddL + Round(wksht.Range(Chr$(Alphabet) & Counter))
BlnL6L9 = True
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr) '.Range("A" & Counter).Rows 'wksht2.Range("A" & Counter, "BG" & Counter).Row
RowCntr = RowCntr + 1
End If
Else
If Bilang > 0 Then
Bilang = Bilang - 1
If BlnL6L9 = True Then
Bilang2 = Bilang2 + 1
If Bilang2 <= 7 Then '4 Then
If Bilang2 = 2 Then
AddL2 = AddL2 + Round(wksht.Range(Chr$(Alphabet) & Counter))
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy '.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr)
RowCntr = RowCntr + 1
End If
ElseIf Bilang2 = 3 Then
AddL3 = AddL3 + Round(wksht.Range(Chr$(Alphabet) & Counter))
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy '.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr)
RowCntr = RowCntr + 1
End If
ElseIf Bilang2 = 4 Then
AddL4 = AddL4 + Round(wksht.Range(Chr$(Alphabet) & Counter))
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy '.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr)
RowCntr = RowCntr + 1
End If
'************************************************* *****************
ElseIf Bilang2 = 5 Then
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy '.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr)
RowCntr = RowCntr + 1
End If
ElseIf Bilang2 = 6 Then
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy '.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr)
RowCntr = RowCntr + 1
End If
ElseIf Bilang2 = 7 Then
If IsNextCol = False Then
wksht.Range("A" & Counter).EntireRow.Copy '.Copy
xlBook2.ActiveSheet.Paste Destination:=xlBook2.Worksheets("summary").Range(" A" & RowCntr)
RowCntr = RowCntr + 1
End If
'Bilang2 = 1
'************************************************* *****************
End If
Else
BlnL6L9 = False
Bilang2 = 1
End If
End If
End If

End If
Counter = Counter + 1
Screen.MousePointer = vbDefault
Next c


If HasCaption Then
With wksht2
.Range("K" & RowCntr).Font.Size = 10
.Range("K" & RowCntr).Font.Bold = True
.Range("K" & RowCntr).HorizontalAlignment = 2 'Align left
.Range("K" & RowCntr).Value = "Book Value:"
.Range("K" & (RowCntr + 1)).Font.Size = 10
.Range("K" & (RowCntr + 1)).Font.Bold = True
.Range("K" & (RowCntr + 1)).HorizontalAlignment = 2 'Align left
.Range("K" & (RowCntr + 1)).Value = "Monthly Dep.:"
.Range("K" & (RowCntr + 2)).Font.Size = 10
.Range("K" & (RowCntr + 2)).Font.Bold = True
.Range("K" & (RowCntr + 2)).HorizontalAlignment = 2 'Align left
.Range("K" & (RowCntr + 2)).Value = "Lease Payable:"
.Range("K" & (RowCntr + 3)).Font.Size = 10
.Range("K" & (RowCntr + 3)).Font.Bold = True
.Range("K" & (RowCntr + 3)).HorizontalAlignment = 2 'Align left
.Range("K" & (RowCntr + 3)).Value = "Interest:"
End With
HasCaption = False
End If

With wksht2
.Range(Chr$(Alphabet) & RowCntr).Font.Size = 10
.Range(Chr$(Alphabet) & RowCntr).Font.Bold = True
.Range(Chr$(Alphabet) & RowCntr).HorizontalAlignment = 1 'Align Right
.Range(Chr$(Alphabet) & RowCntr).Value = Format(AddL, "#,###,###.#0")
.Range(Chr$(Alphabet) & RowCntr + 1).Font.Size = 10
.Range(Chr$(Alphabet) & RowCntr + 1).Font.Bold = True
.Range(Chr$(Alphabet) & RowCntr + 1).HorizontalAlignment = 1 'Align Right
.Range(Chr$(Alphabet) & RowCntr + 1).Value = Format(AddL2, "#,###,###.#0")
.Range(Chr$(Alphabet) & RowCntr + 2).Font.Size = 10
.Range(Chr$(Alphabet) & RowCntr + 2).Font.Bold = True
.Range(Chr$(Alphabet) & RowCntr + 2).HorizontalAlignment = 1 'Align Right
.Range(Chr$(Alphabet) & RowCntr + 2).Value = Format(AddL3, "#,###,###.#0")
.Range(Chr$(Alphabet) & RowCntr + 3).Font.Size = 10
.Range(Chr$(Alphabet) & RowCntr + 3).Font.Bold = True
.Range(Chr$(Alphabet) & RowCntr + 3).HorizontalAlignment = 1 'Align Right
.Range(Chr$(Alphabet) & RowCntr + 3).Value = Format(AddL4, "#,###,###.#0")
End With

AddL = 0
AddL2 = 0
AddL3 = 0
AddL4 = 0
Duplicate = 0
Counter = 6

IsNextCol = True
Next Alphabet

With wksht2
.Range("B" & (RowCntr - 1), "I" & (RowCntr - 1)).Borders.LineStyle = 1
.Range("B" & (RowCntr - 1), "I" & (RowCntr - 1)).Borders.Weight = 3
End With

'************************************************
RowCntr = 6
'************************************************

xlApp.Visible = True

Set xlSheet = xlBook.Worksheets("summary")
xlSheet.Visible = xlSheetHidden

'*Rename the worksheet
With xlBook
.Sheets("summary (2)").Name = "fsummary" 'rename the sheet
Set wksht = .Sheets("fsummary") 'make this the active sheet
End With


End If '*Lease No

xlBook.Close

Screen.MousePointer = vbDefault
Case 1 '*Cancel
Unload Me
End Select
EndShow:
xlApp.WindowState = xlMaximized
Alphabet = 0
Letters = 0

Set c = Nothing
Set foundcell = Nothing
Set xlApp = Nothing
Set xlBook = Nothing
Set xlBook2 = Nothing '*
Set xlSheet = Nothing
Set wksht = Nothing
Set wksht = Nothing '*
Screen.MousePointer = vbDefault
Exit Sub
ErrDisplay:
MsgBox Err.Description & "" & Err.Source, vbInformation
Screen.MousePointer = vbDefault
End Sub

[Killer42]

Can you give us a bit more of an explanation as to what this code is meant to achieve? There is way too much of it to be just doing a simple search. And it's quite a lot to read.

[Esmael]

Hi...

From VB 6 using text box, i have two option of searching Lease No Column C on excel and Group Name column L. so from VB6 the program will read from the Excel File A and copy its summary sheets and add new tabs with name "summary 2" and transfer all the data to Excel File B same format with Excel File A.... but this one is a blank.... so the data from excel A-Copy by the program to write it to excel B.

The Excel also has a pattern that program also detects... if he find the search item... the program will start counting form 4 to 7.... because data starts at row 4. each group/Lease no is consist of 7 rows the program adopt that...
So all i need now is how to rewrite this code... below is my code that makes the program slow and eats lot of memory!


This part cause the delay! The copyng.....!!!
xlApp.Worksheets.Copy xlApp.Worksheets("summary") '*** This part cause the delay


is there any alternative for this one?


(i hope i could attached screenshots or the excel files here)


Thank You!

[Killer42]

I'll look into this when I have some time - just about to leave work now.

You can add attachments, but note the following. You only get five minutes to edit a message after posting it. And to add an attachment you have to edit the post and hit the "Manage attachments" button in the "Additional options" section.

[Esmael]

I'll look into this when I have some time - just about to leave work now.

You can add attachments, but note the following. You only get five minutes to edit a message after posting it. And to add an attachment you have to edit the post and hit the "Manage attachments" button in the "Additional options" section.

I cant find were to attached my attachment!!! That module is fully functional... all i need is to know how to re-write that code. It eats a lot of memory. My PC memory is 2Gig , but if it runs on the lower memory it stop. maybe that is one of the limitation of excel...


Due to business also i cant focus on this one...i believed you could help me.

Thank YOu!

[Killer42]

I cant find were to attached my attachment!!! That module is fully functional... all i need is to know how to re-write that code. It eats a lot of memory. My PC memory is 2Gig , but if it runs on the lower memory it stop. maybe that is one of the limitation of excel...

Due to business also i cant focus on this one...i believed you could help me.

I'll try. However, I may not be able to spend any time on this until the weekend. (It's Wednesday afternoon here now).

The problem may be one inherent in Excel, but it's likely that we can improve on it.

As for attachments, I'll try to attach a couple of screenshots here to show what I'm referring to. It's possible, of course, that you don't have the ability to add attachments. This has cropped up once or twice before, but I think it has all been fixed.

Note that if you just see a small bar with "Additional Options" at the left and a box with a "+" at the right (see 2nd image) then you need to click the "+" to expand the section.

[Esmael]

HI...


I'ved done my first step... i manage to decreased its memory usage... but still need more...



is there anyone who can help me with this....?


thank you ....

[Killer42]

Sorry, I remembered this once or twice on the weekend, but couldn't recall which thread it was. I've just e-mailed a link home so I'll be able to find it this evening. I won't have time to go into it until then.

How did you reduce the memory useage? Perhaps you had better post the latest version of the code. Or if the changes weren't too extensive, just the modified part, or a description of the change so I can apply it to the original code before I play with it.

[Killer42]

I've been having a bit of a look at the code just now. I started out by trying to tidy up the indenting to make it easier to follow, but I keep getting lost because of the weird IF statements. Do you think you could break them down to clearer multi-line If .. End If structures?

For example...

  If CboGroups.Enabled = True Then _
    If CboGroups.Text = "ALL" Then xlApp.Visible = True: GoTo EndShow
 

I can'work out where control goes under what conditions, here. For a start you've got a single-line IF masquerading as a multi-line one. Then there are the multiple statements separated by colons, that I haven't seen used in ten years or something, hanging on the end of the line. When is the GoTo executed? I'm so confused...

This use of the continuation character on an IF statement is, in my opinion, a really bad idea. It leaves the reader searching for an End If statement. Unless they are reading with great care (which, let's face it, few do).

Presumably I could work it out given time, but I don't have a lot of time available to put into it, and it should be simpler for you since you already know your logic.

I give up... help! :)

[Esmael]

Thanx for the comments killer42,

actually this code was properly indented in my source ... sorry if i just copy ang paste it here... i know the burden of aligning it... specially the logic. But thank you... sorri i still dont know how to attached code here...hehehehehe


Happy New Year

[Killer42]

actually this code was properly indented in my source ... sorry if i just copy ang paste it here... i know the burden of aligning it... specially the logic. But thank you... sorri i still dont know how to attached code here...hehehehehe

You don't usually need to "attach" code here. Just pasting it in is fine. Normally, we ask you to put [CODE=vb]...[/CODE] tags around it to improve the formatting.

(In this particular case, I tried to add the tags and ran into a bug. For some reason, if the code is really long, putting code tags around it makes it disappear.)

Anyway, given that it has been some months, did you find an answer to this question? With things having gone quiet, probably nobody around here has thought about it.

To demonstrate what I mean about the CODE tags, here is the same piece of code, just pasted in twice. But I'll wrap a CODE=vb tag around the second one.

On Error GoTo ErrDisplay

Select Case Index
Case 0 '*Display
Screen.MousePointer = vbHourglass
If ((txtLN.Enabled = True Or txtLN.Enabled = False) And Len(txtLN.Text) = 0) Then
If CboGroups.Enabled = False Then
MsgBox "Input Required.", vbInformation
Screen.MousePointer = vbDefault
Exit Sub
End If
End If

On Error GoTo ErrDisplay
 
    Select Case Index
        Case 0 '*Display
        Screen.MousePointer = vbHourglass
        If ((txtLN.Enabled = True Or txtLN.Enabled = False) And Len(txtLN.Text) = 0) Then
            If CboGroups.Enabled = False Then
                MsgBox "Input Required.", vbInformation
                Screen.MousePointer = vbDefault
                Exit Sub
            End If
        End If

Dunno about you, but I find the second version a lot easier to follow.