ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: konggs

VBA代码宝- 代码库商店

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2020-11-20 17:49 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
请问这个软件是咋用呢?必须自己搜集代码储存吗?

TA的精华主题

TA的得分主题

发表于 2020-12-22 11:32 | 显示全部楼层
liuyuanqing 发表于 2018-11-9 15:51
Sub 提取照片属性()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolde ...

这个确实好,关键是我写不出来

TA的精华主题

TA的得分主题

发表于 2021-2-1 16:09 | 显示全部楼层
小白,下个代码宝  自己做数据

TA的精华主题

TA的得分主题

发表于 2021-3-26 12:14 | 显示全部楼层
Private Function round5(x As Double, y As Integer) As Double '自定义函数,四舍六入五单双
'说明:y为整数,为-1时为修约至10位数;-2时修约至百位数;为1时修约1位小数,为2时修约2位小数
Application.Volatile '易失性函数
x = VBA.Round(x, 10) '消除浮点对计算的影响
If y < 0 Then
    round5 = VBA.Round(x * 10 ^ y, 0) / 10 ^ y
Else
    round5 = VBA.Round(x, y)
End If
End Function

TA的精华主题

TA的得分主题

发表于 2021-5-18 14:43 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-7-10 21:12 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
先来看看,留个记号。

TA的精华主题

TA的得分主题

发表于 2021-7-21 13:11 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-12-23 14:39 | 显示全部楼层
'使用adodb连接EXCEL文件,并使用sql查询和输出。

sub sql( )
    Dim Conn As Object, Rst As Object
    Dim strConn As String, strSQL As String
    Dim i As Integer, PathStr As String
    Set Conn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
    PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
    Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
    Case Is <= 11
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    Case Is >= 12
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    End Select
    '设置SQL查询语句
    strSQL = "SELECT DISTINCT 发站 FROM [LMSData2016.12$]"
    Conn.Open strConn    '打开数据库链接
    Set Rst = Conn.Execute(strSQL)    '执行查询,并将结果输出到记录集对象
    With Sheet1
        .Cells.Clear
        For i = 0 To Rst.Fields.Count - 1    '填写标题
            .Cells(1, i + 1) = Rst.Fields(i).Name
        Next i
        .Range("A2").CopyFromRecordset Rst
        .Cells.EntireColumn.AutoFit  '自动调整列宽
    End With
    Rst.Close    '关闭数据库连接
    Conn.Close
    Set Conn = Nothing
    Set Rst = Nothing
End Sub

TA的精华主题

TA的得分主题

发表于 2021-12-24 12:03 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
选定区域 选定行列数 转换
Sub Aki()
    '功能 :将选中区域按照 inputbox 输入的 两个参数分割并合并,将结果放置在所选单元格
    Dim rng As Range, a As Variant
    Dim lr As Integer, lr2 As Integer
    Dim lc As Integer, lc2 As Integer
    Dim i As Integer, J As Integer, t As Integer, u As Integer, rowint As Integer, colint As Integer, bol As Integer
    Dim arr
    Dim BRR
    On Error GoTo msg
    Set rng = Selection
    lr = rng.Rows.Count     '选中区域总行数
    lc = rng.Columns.Count  '选中区域总列数
    a = Split(Application.InputBox("请输入2个参数,以,隔开:" & vbCrLf & "分割的列数 ,分割的行数" & vbCrLf & "(分割方向 向右&向下)"), ",")
    colint = a(0)  '分割列数
    rowint = a(1)  '分割行数
    If lc Mod colint <> 0 Then
        MsgBox "分割列数只能为区域总列数整除的倍数!"
        Exit Sub
    ElseIf lr Mod rowint <> 0 Then
        MsgBox "分割行数只能为区域总行数整除的倍数!"
        Exit Sub
    End If
    i = lr * lc / colint
    ReDim BRR(1 To i, 1 To colint)
    arr = rng
    m = 1
    u1 = 1
    If rowint > 1 Then
        For u = 1 To (lr * lc) / (colint * rowint)  '根据行列得出分割块数
            For t = 1 To colint * rowint            '每个分割块内单元格总数
                Y = Y + 1
                y1 = y1 + 1
                BRR(u1, y1) = arr(m, Y)
                'MsgBox BRR(u1, y1)
                If t Mod colint = 0 And t <> 1 And t < colint * rowint Then '循环到每个分割块第一行右边一列时   □□■
                    m = m + 1                                                                                  '□□□
                    If t Mod colint = 0 Then                                                                   '□□□
                        Y = Y - colint
                    Else
                        Y = 0
                    End If
                    y1 = 0
                    u1 = u1 + 1
                ElseIf t Mod colint = 0 And t = colint * rowint And u * colint Mod lc <> 0 Then  '循环到每个分割块右边一列时 且最后一个单元格时  □□□
                    m = m - rowint + 1                                                                                                          '□□□
                    u1 = u1 + 1                                                                                                                 '□□■
                    y1 = 0
                ElseIf t Mod colint = 0 And t <> colint * rowint Then        '循环到分割块右边一列时 且 非最后一个单元格时      '□□□
                    m = m + 1                                                                                                   '□□■
                    u1 = u1 + 1                                                                                                 '□□□
                    If t Mod colint = 0 Then
                        Y = Y - colint
                    Else
                        Y = 0
                    End If
                    y1 = 0
                ElseIf t Mod colint = 0 And t = colint * rowint And u * colint Mod lc = 0 Then '循环到区域右侧分割块最后一个单元格时      □□□ □□□
                    m = m + 1                                                                                                            '□□□ □□□
                    Y = 0                                                                                                                '□□□ □□■
                    y1 = 0
                    u1 = u1 + 1
                Else
                End If
            Next
        Next
    Else
        For u = 1 To lr * lc / colint
            For t = 1 To colint * rowint
                Y = Y + 1
                BRR(u, t) = arr(m, Y)
                If u * colint Mod lc = 0 And t = colint Then
                    m = m + 1
                Else
                End If
                If Y = lc Then
                    Y = 0
                Else
                End If
            Next
        Next
    End If
    Set rng = Application.InputBox("请选择结果存放单元格:", Type:=8)
    Range(rng.Address).Resize(i, colint) = BRR
    Exit Sub
msg:
    MsgBox ("分割参数错误,请确认!")
    Exit Sub
End Sub

TA的精华主题

TA的得分主题

发表于 2021-12-31 10:26 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 21:00 , Processed in 0.054747 second(s), 7 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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