VBA代码宝- 代码库商店

lpxkk

先学习一下，谢谢分享

feiren228

自己收藏的连接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. 
    
27.     rs.Close
    
28. 
    
29.     Set rs = Nothing
    
30.     Set cnn = Nothing
    
31. End Sub
    

复制代码

Zenray

批量一个文件夹里面的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

Zenray

批量修改文件的文件名
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

星河中的一粒沙

wjh426 发表于 2018-12-7 17:23
win7    32位，已装.NET4.0和VSTO，未能成功安装，提示如下图

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

星河中的一粒沙

zhj85128 发表于 2018-11-28 15:44
超级好的工具，但是我电脑(Win10, office 365 )好像无法安装成功。

这个版本的OFFICE，无法安装，有解决办法吗？win10系统64位，.net4.5

hxg1026

不觉明历，永远支持你

d2xingshou

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

EH258369

小白感觉这些代码很像bat

eyzhong

收藏下............