西安做网站哪家公司好,餐饮网站建设怎么建设的,关于新品牌的营销策划,制作网页教程简单1.后台打开Excel 用于查数据#xff0c;工作中要打开多个表获取数据再关闭的场景#xff0c;利用此函数可以将excel表格作为后台数据库查询#xff0c;快速实现客户要求#xff0c;缺点是运行效率不够高。
Sub openexcel(exl_name As String)If Dir(addr, 16) Empty Then… 1.后台打开Excel 用于查数据工作中要打开多个表获取数据再关闭的场景利用此函数可以将excel表格作为后台数据库查询快速实现客户要求缺点是运行效率不够高。
Sub openexcel(exl_name As String)If Dir(addr, 16) Empty Thenfile_error TrueExit SubEnd IfSet fso CreateObject(Scripting.FileSystemObject).GetFolder(addr \)file_name For Each file In fso.FilesIf InStr(file.Name, exl_name .) 0 And exl_name And InStr(file.Name, $) 1 Thenfile_name file.Name fso.pathDebug.Print file.NameEnd IfNextSet fso NothingIf InStr(file_name, xlsm) 0 And InStr(file_name, 蝶阀) 0 Thenvba_s TrueElsevba_s FalseEnd IfIf file_name Thenstr_path addr \ file_nameDebug.Print str_pathIf IsWbOpen1(str_path) Then 判断excel是否已经打开ElseSet wb GetObject(str_path)Application.Windows(wb.Name).Visible Falsefind_if_open TrueEnd IfElseMsgBox 报错:工作区中不存在该文件file_error TrueExit SubEnd If 2.判断文件是否已打开 避免重复打开客户已经打开的文件提升体验和效率
Function IsWbOpen1(strPath As String) As Boolean如果目标工作簿已打开则返回TRUE否则返回FALSEDim oi As IntegerFor oi Workbooks.Count To 1 Step -1If Workbooks(oi).FullName strPath Then Exit ForNextIf oi 0 ThenIsWbOpen1 FalseElseIsWbOpen1 TrueEnd If
End Function
3.生成新Excel
针对需要把结果生成一张新表格的客户
Public Sub export_excel(control As Office.IRibbonControl)Dim sourceWorkbook As WorkbookDim targetWorkbook As WorkbookDim sourceSheet As WorksheetDim newFileName As Stringshtn Sheets(参数).Cells(2, 2) 设置源工作簿和工作表Set sourceWorkbook ThisWorkbook 当前工作簿Set sourceSheet sourceWorkbook.Sheets(扭矩查询) 要导出的工作表名称 创建新的工作簿Set targetWorkbook Workbooks.Add 拷贝工作表到新工作簿sourceSheet.Copy before:targetWorkbook.Sheets(1) 设置新工作簿的文件名newFileName shtn factory- Format(Now(), YYYYMMDDhhmmss) .xlsx 新文件名 保存新工作簿With targetWorkbook.SaveAs Filename:ThisWorkbook.Path \ newFileName, FileFormat:xlOpenXMLWorkbook.Close SaveChanges:FalseEnd With 清理Set sourceSheet NothingSet targetWorkbook NothingSet sourceWorkbook Nothing
End Sub
4.延时
针对需要等待的场景比如等待加载
Public Declare PtrSafe Function timeGetTime Lib winmm.dll () As Long
------------延时------------
Sub delay1(T As Single) 秒级的延时Dim time1 As Singletime1 TimerDoDoEventsLoop While Timer - time1 T
End SubSub delay(T As Single) 毫秒级的延时(需要引用dll)Dim time1 As Singletime1 timeGetTimeDoDoEventsLoop While timeGetTime - time1 T
End Sub
------------延时------------
5.链接Access数据库
Sub ExportDataToAccess(arrFileds As Variant, datas As Variant, sheetName As String)Dim conString$, sqlString$Dim cnn, rstSet cnn CreateObject(ADODB.Connection) 创建连接对象Set rst CreateObject(ADODB.Recordset) 创建记录集对象conString providerMicrosoft.ace.OLEDB.12.0;Data Source ThisWorkbook.path _ \test.accdb;cnn.Open conString 连接Access数据库rst.Open select * from sheetName where 12, cnn, adOpenDynamic, _adLockOptimisticrst.AddNew arrFileds, datas 数组插入到Accesscnn.Close 关闭连接对象
End Sub
6.调节图片长宽比
此函数能调节插入图片的长宽比通过等边距裁剪使图片在Excel中排版统一
--------------------------调整图片长宽比---------------------------
Sub change_sacle(shp As Shape, scal As Double) scale为长宽比推荐值1.5If shp.Type 13 Then 当shape对象类型是图片的时候才开始统计图片的值13Dim xCrop As Object, xl As Double, xt As Doubleshp.ScaleHeight 0.995, msoTrue, msoScaleFromTopLeftshp.ScaleWidth 1.05, msoTrue, msoScaleFromTopLeftshp.PictureFormat.Crop.PictureOffsetX 0shp.PictureFormat.Crop.PictureOffsetY 0shp.PictureFormat.Crop.ShapeWidth shp.PictureFormat.Crop.PictureWidthshp.PictureFormat.Crop.ShapeHeight shp.PictureFormat.Crop.PictureHeightIf shp.Width / shp.Height - scal 0.05 Or scal - shp.Width / shp.Height 0.05 Then 允许一些误差防止无限裁剪Debug.Print 执行If shp.Width / shp.Height scal Then 宽了裁剪左右xl (shp.Width - shp.Height * scal) / 2Debug.Print xlSet xCrop shp.PictureFormat.Crop 返回一个Crop对象With xCrop 设置裁剪格式.ShapeLeft shp.Left xl 裁剪左边.ShapeWidth .PictureWidth - 2 * xl 裁剪宽度.PictureOffsetX 0.PictureOffsetY 0End WithElse 高了裁剪上下xt (shp.Height - shp.Width / scal) / 2Debug.Print xtDebug.Print 高了Set xCrop shp.PictureFormat.Crop 返回一个Crop对象With xCrop 设置裁剪格式.ShapeTop shp.Top xt 裁剪顶部.ShapeHeight .PictureHeight - 2 * xt 裁剪高度.PictureOffsetX 0.PictureOffsetY 0End WithEnd IfEnd IfEnd If
End Sub
--------------------------调整图片长宽比---------------------------
7.获取一段函数的运行时间
------------获取一段函数运行时间------------
Sub GetRunTime()Dim i As LongDim dteStart As DateDim strTime As StringApplication.ScreenUpdating False关闭屏幕刷新dteStart Timer---------运行过程主体-------
MkDir D:\Bomad\Assembly---------运行过程主体-------strTime Format((Timer - dteStart), 0.00000)MsgBox 运行过程: strTime 秒Application.ScreenUpdating True打开屏幕刷新
End Sub
------------获取一段函数运行时间------------
持续更新中......
