Excel自动化 - 使用Visual Basic 6 [英] Excel Automation-With Visual Basic 6
问题描述
[left]
大家好，
/ ******************* ********** /
OS-WIn XP SP2
VB6 SP6
/ ******* ********************** /
他们的任何人都可以帮助我：
在VB6上编写的源代码。
描述：
当此程序被触发时。它将从excel文件中读取和搜索，并将INPUTTED文本定位为搜索项。搜索将从列L开始到Z，并从行 L6 开始到 L2915 ''
（这是我在vb6中的旧程序，由于业务我不能专注于此）
这个模块已经工作了......问题是它吃了很多资源.. 。
任何人都可以告诉我如何重写这段代码......？
任何帮助都表示赞赏...
谢谢！
Private Sub Cmd_Click（索引为整数）
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作为新工作表''*参考工作表
Dim wksht2作为新工作表''*参考工作表
Dim Var1 As String''保存搜索字符串
Dim ctr As Long，Duplicate作为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''每月深度。
Dim AddL3 As货币：AddL3 = 0''租赁支付
Dim AddL4 As Currency：AddL4 = 0''Interest
Dim BlnL6L9作为布尔值，OK_Item作为布尔''第六行到第九行
BlnL6L9 = False：OK_Item = False
Dim RowCntr As Long：RowCntr = 6
Dim IsNextCol作为布尔值：IsNextCol = False
Dim Alphabet as Integer
Dim Letters as Integer
Dim A
错误GoTo ErrDisplay
选择案例索引
案例0''*显示
Screen.MousePointer = vbHourglass
If（（txtLN.Enabled = True或txtLN.Enabled = False）和Len（txtLN.Text）= 0）然后''或（（CboGroups。 Enabled = True或CboGroups.Enabled = False） d Len（CboGroups.Text）= 0）然后
如果CboGroups.Enabled = False那么
MsgBox输入必需。，vbInformation
Screen.MousePointer = vbDefault
退出Sub
结束如果
结束如果
设置xlApp =新Excel.Application
设置xlBook = xlApp.Workbooks.Open（" C：\ Fix assets \Asset Managment（2）（2）10 03 2006.xls" ;）
如果CboGroups.Enabled = True则_
如果CboGroups.Text =" ALL"然后xlApp.Visible = True：GoTo EndShow
设置xlSheet = xlApp.Worksheets（" summary"）
xlSheet.Visible = xlSheetVisible
''*********************************群组
如果Opt（0）.Value = True那么''Groups''where = trim（CboGroups.text）
''复制工作表摘要
xlApp.Worksheets.Copy xlApp.Worksheets（" summary"）
设置wksht = xlApp.Worksheets（" summary（2）"）''xlBook。工作表（1）
wksht.Activate
Var1 =修剪（CboGroups.Text）
设置foundcell = xlBook.Worksheets（ 摘要。列。（L）。查找（Var 1）
''如果在L列中没有找到则转移到其他列（MZ）
如果找到了什么都没有呢
For Letters = 77 To 90
设置foundcell = xlBook.Worksheets（" summary"）。列（Chr $（字母））.Find（ Var1）
如果没有找到单位则没有则退出
下一封信
结束如果
''如果没有从列（AZ）中找到
如果找不到则
MsgBox未找到。，vbInformation
Screen.MousePointer = vbDefault
退出Sub
结束如果
重复= 0''将计数器设置为0跟踪多少重复
Counter = 6''行指示符/计数...从行6开始
Bilang2 = 1''计数1到4行
Dim blnFirst As Boolean：blnFirst = True
Dim blnUna As Boolean
Dim Merun As Boolean
''**************************** ******* EXCEL TEMPLATE
设置xlBook2 = xlApp.Workbooks.Open（App.Path& " \Asset Managment Template.xls"）
''***************************** ****** EXCEL TEMPLATE
''******************************** *******
设置wksht2 = xlBook2.Worksheets（" summary"）
wksht2.Activate
xlApp.DisplayAlerts = False
xlBook2.Saved = True
''********************** *****************
For each c in wksht.Range（" L6：L2915"）''查找范围和实例
Screen.MousePointer = vbHourglass
如果修剪（CStr（wksht.Range（" K"& Counter）））=Group然后''和OK_Item = True然后
如果修剪（CStr（wksht.Range（K& Counter）））=Group然后''而不是IsNull（修剪（CStr（wksht.Range（L& Counter））））然后
对于Alphabet = 76到90''LZ
如果修剪（CStr（wksht.Range（Chr $（字母）和计数器）））=修剪（Var1）然后_
Merun =真
Next Alphabet
如果Merun = True那么
重复=重复+ 1
Bilang = 7''9
BlnL6L9 = True
wksht.Range（" A"&（Counter - 4））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（QUOT;总结"）范围（A; &安培; RowCntr）''。Range（" A&& Counter）.Rows''wksht2.Range（"&& Counter，" BG&& Counter）.Row
RowCntr = RowCntr + 1
wksht.Range（" A"&（Counter - 3））。EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination ：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）''。范围（" A&& Counter）.Rows''wksht2.Range（" A"& Counter） ，BG& Counter）。行
RowCntr = RowCntr + 1
wksht.Range（" A&&（Counter - 2） ））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（"） A&& RowCntr）''。范围（A和A。 &安培; Counter）.Rows''wksht2.Range（"&& Counter，" BG&& Counter）.Row
RowCntr = RowCntr + 1
wksht.Range（" A"&（Counter - 1））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（A& RowCntr）''。范围（A和计数器.Rows''wksht2.Range（"&& Counter，" BG&& Counter）.Row
RowCntr = RowCntr + 1
wksht.Range（" A&（Counter））。EntireRow.Copy
xlBook2 .ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）''。范围（&A& & Counter.Rows''wksht2.Range（" A" &安培;计数器，BG &安培;柜台）。行
RowCntr = RowCntr + 1
''******************* ****************************** *****************
wksht.Range（" A"&（Counter + 1））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"） .Range（A& RowCntr）''。Range（"&& Counter）.Rows''wksht2.Range（"&& Counter，" BG&& Counter）.Row
RowCntr = RowCntr + 1
wksht.Range（" A&（Counter + 2））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）''。。 GE（QUOT; A" &安培; Counter）.Rows''wksht2.Range（"&& Counter，" BG&& Counter）.Row
RowCntr = RowCntr + 1
' ******************* *****************
结束如果
Bilang2 = 1
Merun = False
结束如果
结束如果
Counter = Counter + 1
Screen.MousePointer = vbDefault
下一页c
''*************************** ********************** **************************** **********
柜台= 0
Bilang = 0
Bilang2 = 0
xlApp.Visible = True
设置xlSheet = xlBook.Worksheets（" summary"）
xlSheet.Visible = xlSheetHidden
ElseIf选项（1）.Value = True然后''Lease Nos。''where = trim（TxtLN.text）
''*** *******************************租赁编号
''复制工作表总结
xlApp.Worksheets.Copy xlApp.Worksheets（" summary"）
设置wksht = xlApp.Worksheets（" summary（2）"）''xlBook .Worksheets（1）
wksht.Activate
''设置Var1 = xlBook.Worksheets（" summary"）。范围（" c6"）
Var1 = UCase（Trim（txtLN.Text））
设置foundcell = xlBook.Worksheets（" summary"）。列（" C"）。查找（ Var 1）
如果找不到那么
MsgBox未找到。，vbInformation
Screen.MousePointer = vbDefault
退出Sub
结束如果
Dim HasCaption As Boolean：HasCaption = True
重复= 0''将计数器设置为0
计数器= 6''行指示符/计数
Bilang2 = 1''计数1到4行
''*********************************** EXCEL TEMPLATE
设置xlBook2 = xlApp.Workbooks.Open（App.Path& " \Asset Managment Template.xls"）
''***************************** ****** EXCEL TEMPLATE
''******************************** *******
设置wksht2 = xlBook2.Worksheets（" summary"）
wksht2.Activate
xlApp.DisplayAlerts = False
xlBook2.Saved = True
''********************** *****************
字母表= 76至90''LZ
For Each c in wksht.Range（" C6：C2915"）''查找范围和实例
Screen.MousePointer = vbHourglass
如果c.Value = Var1然后
重复=重复+ 1
Bilang = 7
Bilang2 = 1
AddL = AddL + Round（wksht.Range（Chr $（Alphabet）&柜台））
BlnL6L9 =真
如果IsNextCol = False那么
wksht.Range（" A&& Counter）.EntireRow。复制
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）''。范围（" A&& Counter） .Rows''wksht2.Range（" A& Counter，" BG&& Counter）。行
RowCntr = RowCntr + 1
结束如果
否则
如果Bilang> 0然后
Bilang = Bilang - 1
如果BlnL6L9 = True那么
Bilang2 = Bilang2 + 1
如果Bilang2< = 7然后''4然后
如果Bilang2 = 2那么
AddL2 = AddL2 + Round（wksht.Range（Chr $（Alphabet）& Counter） ）
如果IsNextCol = False那么
wksht.Range（" A&& Counter）.EntireRow.Copy''。复制
xlBook2.ActiveSheet.Paste Destination：= xlBook2.Worksheets（" summary"）。Range（"& RowCntr）
RowCntr = RowCntr + 1
结束如果
ElseIf Bilang2 = 3那么
AddL3 = AddL3 + Round（wksht.Range（Chr $（Alphabet）& ;柜台））
如果IsNextCol = False那么
wksht.Range（" A&& Counter）.EntireRow.Copy''。复制
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）
RowCntr = RowCntr + 1
结束如果
ElseIf Bilang2 = 4那么
AddL4 = AddL4 + Round（wksht.Range（Chr $（Alphabet）& Counter））
如果IsNextCol = False那么
wksht.Range（" A"& Counter）.EntireRow.Copy''。复制
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A" &安培; RowCntr）
RowCntr = RowCntr + 1
结束如果
''*************** ********************************** **************** *
ElseIf Bilang2 = 5然后
如果IsNextCol = False那么
wksht.Range（" A&& Counter）.EntireRow。复制''。复制
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）
RowCntr = RowCntr + 1
结束如果
ElseIf Bilang2 = 6那么
如果IsNextCol = False那么
wksht.Range（" A" &安培; Counter）.EntireRow.Copy''。复制
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（" A& RowCntr）
RowCntr = RowCntr + 1
结束如果
ElseIf Bilang2 = 7那么
如果IsNextCol = False那么
wksht.Range（" A"& Counter）.EntireRow.Copy''。Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。 （A& RowCntr
RowCntr = RowCntr + 1
结束如果
''Bilang2 = 1
''************************* ************************ *****************
结束如果
Else
BlnL6L9 = False
Bilang2 = 1
结束如果
结束如果
结束如果
结束如果
计数器=计数器+ 1
Screen.MousePointer = vbDefault
下一页c
如果HasCaption则
使用wksht2
.Range（QUOT; K" &安培; RowCntr）.Font.Size = 10
.Range（" K"& RowCntr）.Font.Bold = True
.Range（" K"& RowCntr）.HorizontalAlignment = 2''左对齐
.Range（" K"& RowCntr）.Value ="账面价值："
.Range（ " K"&（RowCntr + 1））。Font.Size = 10
.Range（" K"&（RowCntr + 1））。Font.Bold = True
.Range（" K"&（RowCntr + 1））。HorizontalAlignment = 2''左对齐
.Range（" K"&（RowCntr + 1） ）.Value =" Monthly Dep.:"
.Range（" K"&（RowCntr + 2））。Font.Size = 10
。范围（K&（RowCntr + 2））。Font.Bold = True
.Range（" K" &安培; （RowCntr + 2））。HorizontalAlignment = 2''左对齐
.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''左对齐
.Range（" K" ;&（RowCntr + 3））。值="兴趣："
结束
HasCaption = False
结束如果
随wksht2
.Range（Chr $（Alphabet）& RowCntr）.Font.Size = 10
.Range（ Chr $（Alphabet）& RowCntr）.Font.Bold = True
.Range（Chr $（Alphabet）& RowCntr）.HorizontalAlignment = 1''对齐
.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''对齐
.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''对齐
.Range（Chr $（Alphabet）& Ro wCntr + 2）.Value =格式（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''对齐
.Range（Chr $（Alphabet）& RowCntr + 3）.Value = Format（AddL4，"＃ ，###，###。＃0"）
结束
AddL = 0
AddL2 = 0
AddL3 = 0
AddL4 = 0
重复= 0
计数器= 6
IsNextCol = True
下一个字母
随wksht2
.Range（" B"&（ RowCntr - 1），I&（RowCntr - 1））。Borders.LineStyle = 1
。范围（B） &安培; （RowCntr - 1），I &安培; （RowCntr - 1））。Borders.Weight = 3
结束
''************** ********************************** *
RowCntr = 6
''********************************************* ***
xlApp.Visible = True
设置xlSheet = xlBook.Worksheets（" summary"）
xlSheet.Visible = xlSheetHidden
''*重命名工作表
使用xlBook
.Sheets（" summary（ 2）"）。Name =" fsummary" ''重命名工作表
设置wksht = .Sheets（" fsummary"）''使这个活动工作表
结束时
结束如果''*租赁否
xlBook.Close
Screen.MousePointer = vbDefault
案例1''*取消
卸载我
结束选择
EndShow：
xlApp。 WindowState = xlMaximized
Alphabet = 0
来信= 0
设置c =无任何
Set foundcell =没什么
设置xlApp =没什么
设置xlBook =没什么
设置xlBook2 =没什么''*
设置xlSheet = Nothing
设置wksht =没什么
设置wksht =没什么''*
Screen.MousePointer = vbDefault
退出Sub
ErrDisplay：
MsgBox Err.Description& ; "" &安培; Err.Source，vbInformation
Screen.MousePointer = vbDefault
End Sub
[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
推荐答案
（字母））。查找（Var1）
如果找不到，则表示没有，然后退出
下一个字母
结束如果
''如果没有从列中找到（AZ）
如果找不到则
MsgBox未找到。，vbInformation
Screen.MousePointer = vbDefault
退出Sub
结束如果
重复= 0''将计数器设置为0跟踪重复数量
计数器= 6''行指示符/计数...以行6开头
Bilang2 = 1 ''计数1到4行
Dim blnFirst As布尔值：blnFirst = True
Dim blnUna As Boolean
Dim Merun As Boolean
''******************************* **** EXCEL TEMPLATE
设置xlBook2 = xlApp.Workbooks.Open（App.Path& " \Asset Managment Template.xls"）
''***************************** ****** EXCEL TEMPLATE
''******************************** *******
设置wksht2 = xlBook2.Worksheets（" summary"）
wksht2.Activate
xlApp.DisplayAlerts = False
xlBook2.Saved = True
''********************** *****************
For each c in wksht.Range（" L6：L2915"）''查找范围和实例
Screen.MousePointer = vbHourglass
如果修剪（CStr（wksht.Range（" K"& Counter）））=Group然后''和OK_Item = True然后
如果修剪（CStr（wksht.Range（K& Counter）））=Group然后''而不是IsNull（修剪（CStr（wksht.Range（L& Counter））））然后
对于Alphabet = 76到90''LZ
如果修剪（CStr（wksht.Range（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）））=修剪（Var1）然后_
Merun = True
下一个字母
如果Merun = True那么
重复=重复+ 1
Bilang = 7''9
BlnL6L9 = True
wksht.Range（" A&（Counter - 4））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Workshee TS（"总结"）。范围（" A" &安培; RowCntr）''。Range（" A&& Counter）.Rows''wksht2.Range（"&& Counter，" BG&& Counter）.Row
RowCntr = RowCntr + 1
wksht.Range（" A"&（Counter - 3））。EntireRow.Copy
xlBook2.ActiveSheet.Paste Destination ：= xlBook2.Worksheets（" summary"）。范围（" A"& RowCntr）''。范围（" A&& Counter）.Rows''wksht2.Range（" A"& Counter） ，BG& Counter）。行
RowCntr = RowCntr + 1
wksht.Range（" A&&（Counter - 2） ））。EntireRow.Copy
xlBook2.ActiveSheet.Paste目的地：= xlBook2.Worksheets（" summary"）。范围（"） A&& RowCntr）''。范围（A和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& quot; & 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) ’’.Ran ge("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
$b $b AddL = AddL + Round(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))
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
这篇关于Excel自动化 - 使用Visual Basic 6的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
