第3章--Wordbook(工作簿)对象代码【超实用VBA】

25第3章Wordbook（工作簿）对象范例38引用工作簿的方法38-1使用工作簿名称SubWbPath()MsgBoxWorkbooks(38-1使用工作簿名称.xlsm).PathEndSub38-2使用工作簿索引号SubWbName()MsgBox第一个打开的工作簿名字为：&Workbooks(1).NameEndSubSubWbFullName()MsgBox包括完整路径的工作簿名称为：&Workbooks(1).FullNameEndSub38-3使用ThisWorkbook属性SubWbClose()ThisWorkbook.CloseSaveChanges:=FalseEndSub38-4使用ActiveWorkbook属性使用ActiveWorkbook代表活动窗口（顶部窗口）的工作簿，范例代码如下：#001SubWbActive()#002MsgBox当前活动工作簿名字为：&ActiveWorkbook.Name#003EndSub26范例39新建工作簿SubAddNowwb()DimAddNowwbAsWorkbookDimShtNameAsVariantDimArrAsVariantDimiAsIntegerDimMyInNewWbAsIntegerMyInNewWb=Application.SheetsInNewWorkbookArr=Array(品名,单价,数量,金额)ShtName=Array(01月,02月,03月,04月,05月,06月,07月,08月,09月,10月,11月,12月)Application.SheetsInNewWorkbook=12SetAddNowwb=Workbooks.AddWithAddNowwbFori=1To12With.Sheets(i).Name=ShtName(i-1).Range(A1).Resize(1,UBound(Arr)+1)=ArrEndWithNext.SaveAsFilename:=ThisWorkbook.Path&\&存货明细.xlsx.CloseSavechanges:=TrueEndWithApplication.SheetsInNewWorkbook=MyInNewWbSetAddNowwb=NothingEndSub范例40打开指定的工作簿SubOpenwb()Workbooks.OpenThisWorkbook.Path&\123.xlsxEndSub范例41判断指定工作簿是否打开41-1遍历Workbooks集合方法SubWbIsOpenOne()DimWbAsWorkbook27DimWbNameAsStringWbName=abc.xlsxForEachWbInWorkbooksIfWb.Name=WbNameThenMsgBox工作簿&WbName&已经被打开!ExitSubEndIfNextMsgBox工作簿&WbName&没有被打开!EndSub41-2使用错误处理方法#001SubWbIsOpenTwo()#002DimWbAsWorkbook#003DimWbNameAsString#004WbName=abc.xlsx#005OnErrorGoToline#006SetWb=Application.Workbooks(WbName)#007MsgBox工作簿&WbName&已经被打开!#008ExitSub#009line:#010MsgBox工作簿&WbName&没有被打开!#011EndSub范例42关闭工作簿不显示保存对话框42-1使用Close方法关闭工作簿SubwbCloseOne()ThisWorkbook.CloseSaveChanges:=FalseEndSubSubwbCloseTwo()ThisWorkbook.Saved=TrueThisWorkbook.CloseEndSubSubwbCloseThree()ThisWorkbook.SaveThisWorkbook.CloseEndSub2842-2单击工作簿关闭按钮关闭工作簿PrivateSubWorkbook_BeforeClose(CancelAsBoolean)Me.Saved=TrueEndSub范例43禁用工作簿的关闭按钮DimWbCloseAsBooleanPrivateSubWorkbook_BeforeClose(CancelAsBoolean)IfWbClose=FalseThenCancel=TrueMsgBox请使用关闭按钮关闭工作簿!,48,提示EndIfEndSubPublicSubCloseWb()WbClose=TrueThisWorkbook.CloseEndSub范例44保存工作簿的方法44-1使用Save方法SubSaveWb()ThisWorkbook.SaveEndSub44-2直接保存为另一文件名SubSaveAsWb()OnErrorResumeNextThisWorkbook.SaveAsFilename:=ThisWorkbook.Path&\SaveAsWb.xlsmEndSub44-3保存工作簿副本SubSaveCopyWb()29ThisWorkbook.SaveCopyAsThisWorkbook.Path&\SaveCopyWb.xlsmEndSub范例45保存指定工作表为工作簿SubShtCopy()OnErrorGoTolineSheet2.CopyActiveWorkbook.CloseSaveChanges:=True,_Filename:=ThisWorkbook.Path&\ShtCopy.xlsxExitSubline:ActiveWorkbook.CloseFalseEndSub范例46不打开工作簿取得其他工作簿数据46-1使用公式取得数据SubUsingTheFormula()DimTempAsStringTemp='&ThisWorkbook.Path&\[数据.xlsx]Sheet1'!WithSheet1.Range(A1:F22).FormulaR1C1==&Temp&RC.Value=.ValueEndWithEndSub46-2使用GetObject函数SubUseGetObject()DimWbAsWorkbookDimTempAsStringTemp=ThisWorkbook.Path&\数据.xlsxSetWb=GetObject(Temp)WithWb.Sheets(1).Range(A1).CurrentRegionRange(A1).Resize(.Rows.Count,.Columns.Count)=.ValueEndWithWb.CloseFalseSetWb=NothingEndSub3046-3隐藏Application对象SubHideApplication()DimMyAppAsNewApplicationDimShtAsWorksheetDimTempAsStringTemp=ThisWorkbook.Path&\数据.xlsxMyApp.Visible=FalseSetSht=MyApp.Workbooks.Open(Temp).Sheets(1)WithSht.Range(A1).CurrentRegionRange(A1).Resize(.Rows.Count,.Columns.Count)=.ValueEndWithMyApp.QuitSetMyApp=NothingSetSht=NothingEndSub46-4使用ExecuteExcel4Macro方法SubUsingMacroFunction()DimRCountAsLongDimCCountAsLongDimTempAsStringDimTemp1AsStringDimTemp2AsStringDimTemp3AsStringDimrAsLongDimcAsLongDimarr()AsVariantTemp='&ThisWorkbook.Path&\[数据.xlsx]Sheet1'!Temp1=Counta(&Temp&Rows(1).Address(,,xlR1C1)&)CCount=Application.ExecuteExcel4Macro(Temp1)Temp2=Counta(&Temp&Columns(A).Address(,,xlR1C1)&)RCount=Application.ExecuteExcel4Macro(Temp2)ReDimarr(1ToRCount,1ToCCount)Forr=1ToRCountForc=1ToCCountTemp3=Temp&Cells(r,c).Address(,,xlR1C1)arr(r,c)=Application.ExecuteExcel4Macro(Temp3)NextNextRange(A1).Resize(RCount,CCount).Value=arrEndSub3147-5使用SQL连接SubUsingSQL()DimSqlAsStringDimjAsIntegerDimrAsIntegerDimCnnAsADODB.ConnectionDimrsAsADODB.RecordsetWithSheet1.Cells.ClearSetCnn=NewADODB.ConnectionWithCnn.Provider=Microsoft.ACE.OLEDB.12.0.ConnectionString=ExtendedProperties=Excel12.0;_&DataSource=&ThisWorkbook.Path&\数据.xlsx.OpenEndWithSetrs=NewADODB.RecordsetSql=Select*From[Sheet1$]rs.OpenSql,Cnn,adOpenKeyset,adLockOptimisticForj=0Tors.Fields.Count-1.Cells(1,j+1)=rs.Fields(j).NameNextr=.Cells(.Rows.Count,1).End(xlUp).Row.Range(A&r+1).CopyFromRecordsetrsEndWithrs.CloseCnn.CloseSetrs=NothingSetCnn=NothingEndSub