VBA代码宝- 代码库商店

Romance_sur_le_

请问这个软件是咋用呢？必须自己搜集代码储存吗？

凤随心动

liuyuanqing 发表于 2018-11-9 15:51
Sub 提取照片属性()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolde ...

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

xufire

小白，下个代码宝  自己做数据

暮牧

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

snowridgye

跟着各位学习一下

高手你怎么看

先来看看，留个记号。

zminzhu

我的代码大都是抄的，不敢传，怕侵权

29213301

'使用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

shimakaze

选定区域 选定行列数 转换
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

lijunyong

太强大了，神作！