ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
楼主: konggs

VBA代码宝- 代码库商店

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-8 09:07 | 显示全部楼层
先学习一下,谢谢分享

TA的精华主题

TA的得分主题

发表于 2019-1-14 09:45 | 显示全部楼层
自己收藏的连接sql代码
  1. Sub Ado_SQL()
  2.     Dim cnn As Object, rs As Object
  3.     Dim CnStr$, sql$
  4.     Dim DbIp$, DbName$, DbUser$, DbPw$
  5.     T = Timer
  6.     Set cnn = CreateObject("Adodb.Connection")
  7.     Set rs = CreateObject("adodb.recordset")
  8. line:
  9.     DbIp = InputBox("请输入ip地址!", "请输入ip地址!", ".")
  10.     'DbIp = "."  '本机
  11.     If Len(DbIp) = 0 Then GoTo line
  12.     DbName = "test"
  13.     DbUser = "test"
  14.     DbPw = "test"
  15.     CnStr = "Provider=SQLOLEDB;Data Source=" & DbIp & ";DATABASE=" & DbName & ";UID=" & DbUser & ";pwd=" & DbPw
  16.     cnn.Open CnStr
  17.     sql = "select * from test"
  18.    
  19.     Set rs = cnn.Execute(sql)      'cnn.Execute sql
  20.     'rs.Open sql, cnn, 1, 3     'rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
  21.    
  22.     '数据处理
  23.    
  24.     'rng.CopyFromRecordset rs  '复制结果到工作表
  25.     'brr = rs.GetRows  结果导入数组

  26.     rs.Close

  27.     Set rs = Nothing
  28.     Set cnn = Nothing
  29. End Sub
复制代码

评分

参与人数 1鲜花 +1 收起 理由
lozet + 1 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-2-19 21:27 | 显示全部楼层
批量一个文件夹里面的xls 转 xlsx
'***********访问当前文件夹下所有子文件夹及文件,
Dim iFile(1 To 100000) As String
Dim count As Integer

Sub xls2xlsx()
    t = Timer
    Application.ScreenUpdating = False
    iPath = ThisWorkbook.Path
    On Error Resume Next
    count = 0
    zdir iPath
    For i = 1 To count
        If iFile(i) Like "*.xls" And iFile(i) <> ThisWorkbook.FullName Then
            MyFile = iFile(i)
            FilePath = Replace(MyFile, ".xls", ".xlsx")
            If Dir(FilePath, 16) = Empty Then
                total_number = total_number + 1
                Set WBookOther = Workbooks.Open(MyFile)
                Application.ScreenUpdating = False
                ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                WBookOther.Close SaveChanges:=False      '解决不能close 文件问题
                Application.ScreenUpdating = True
            End If
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox total_nmuber & " files has changed in " & Timer - t & " seconds. "
End Sub

Sub zdir(p)       '访问当前文件夹下所有子文件夹及文件
  Set fs = CreateObject("scripting.filesystemobject")
  For Each f In fs.GetFolder(p).Files
    If f <> ThisWorkbook.FullName Then count = count + 1: iFile(count) = f
  Next
  For Each m In fs.GetFolder(p).SubFolders
      zdir m
  Next
End Sub

TA的精华主题

TA的得分主题

发表于 2019-2-19 21:28 | 显示全部楼层
批量修改文件的文件名
Sub 批量获取文件名()
Cells = ""
Dim sfso
Dim myPath As String
Dim Sh As Object
Dim Folder As Object
Application.ScreenUpdating = False
On Error Resume Next
Set sfso = CreateObject("Scripting.FileSystemObject")
Set Sh = CreateObject("shell.application")
Set Folder = Sh.BrowseForFolder(0, "", 0, "")
If Not Folder Is Nothing Then
  myPath = Folder.Items.Item.Path
End If
Application.ScreenUpdating = True
Cells(1, 1) = "旧版名称"
Cells(1, 2) = "文件类型"
Cells(1, 3) = "所在位置"
Cells(1, 4) = "新版名称"
Call 直接提取文件名(myPath & "\")
End Sub

Sub 直接提取文件名(myPath As String)
    Dim i As Long
    Dim myTxt As String
    Set extension = CreateObject("vbscript.regexp")
    With extension
    .Global = False
    .IgnoreCase = True
    .Pattern = "\.\w{2,5}$"
    End With
    i = Range("A1000000").End(xlUp).Row
    myTxt = Dir(myPath, 31)
    Do While myTxt <> ""
    On Error Resume Next
        If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then
            i = i + 1
            If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then
                Cells(i, 2) = "文件夹"
                Cells(i, 1) = "'" & myTxt
            Else
                Cells(i, 2) = extension.Execute(myTxt)(0)
                Cells(i, 1) = "'" & Left(myTxt, Len(myTxt) - Len(Cells(i, 2)))
            End If
            Cells(i, 3) = Left(myPath, Len(myPath) - 1)
        End If
        myTxt = Dir
    Loop
Columns("A:C").EntireColumn.AutoFit
With Cells(1, 1).CurrentRegion
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlThin
    .Interior.PatternColorIndex = xlAutomatic
    .Interior.ThemeColor = xlThemeColorDark1
    .Interior.TintAndShade = -0.349986266670736
End With
Range(Cells(i, 4), Cells(2, 4)).Interior.Color = vbWhite
End Sub

Sub 批量重命名()
Dim y_name As String
Dim x_name As String
For i = 2 To Range("A1000000").End(xlUp).Row
   If Cells(i, 2).Value = "文件夹" Then
   y_name = Cells(i, 3) & "\" & Cells(i, 1)
   x_name = Cells(i, 3) & "\" & Cells(i, 4)
   Else
   y_name = Cells(i, 3) & "\" & Cells(i, 1) & Cells(i, 2)
   x_name = Cells(i, 3) & "\" & Cells(i, 4) & Cells(i, 2)
   End If
   On Error Resume Next
   Name y_name As x_name
Next
MsgBox ("重命名完成啦")
End Sub

TA的精华主题

TA的得分主题

发表于 2019-2-24 09:14 | 显示全部楼层
wjh426 发表于 2018-12-7 17:23
win7    32位,已装.NET4.0和VSTO,未能成功安装,提示如下图

你这个问题解决了吗?我的也安装不了,一样的问题

TA的精华主题

TA的得分主题

发表于 2019-2-24 09:17 | 显示全部楼层
本帖最后由 星河中的一粒沙 于 2019-2-24 09:29 编辑
zhj85128 发表于 2018-11-28 15:44
超级好的工具,但是我电脑(Win10, office 365 )好像无法安装成功。

这个版本的OFFICE,无法安装,有解决办法吗?win10系统64位,.net4.5
3.png
4.png

点评

VBA代码宝跟Office无关,即没有Office的环境,也可以安装(或者只有AutoCaD或wps的环境也是可以安装的)  发表于 2019-3-11 09:46
是不是你不是以管理员方式运行的。或者你当前环境有问题。  发表于 2019-3-11 09:44

TA的精华主题

TA的得分主题

发表于 2019-3-10 08:01 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-3-13 12:12 | 显示全部楼层
Public Function LastRowInColumn(Column As String, Optional ByVal ws As String = "") As Long
'最后一行
        If ws = "" Then ws = ActiveSheet.Name
        LastRowInColumn = Worksheets(ws).Range(Column & Rows.Count).End(xlUp).row

End Function

Public Function LastColumnInRow(row As String, Optional ByVal ws As String = "") As Long
'最后一列
        If ws = "" Then ws = ActiveSheet.Name
        LastColumnInRow = Worksheets(ws).Cells(row, Columns.Count).End(xlToLeft).Column

End Function

TA的精华主题

TA的得分主题

发表于 2019-5-21 23:17 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-6-27 17:42 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-8-7 09:15 , Processed in 0.085001 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表