精华内容
下载资源
问答
  • 使用vb6读取文本,存入access数据库,生成EXCEL报表
  • 使用VB读取EXCEL数据的小程序

    千次阅读 2019-03-05 15:10:50
    使用VB读取EXCEL数据的小程序程序界面部分代码使用VB进行MD5加密的代码 程序界面 VB生成EXE工程时可能由于系统原因会导致按钮文字显示不全,缺字少字的情况,网上搜了好多帖子,有说DLL文件缺失,有说框体不够大等等...

    使用VB读取EXCEL数据的小程序

    程序界面

    VB生成EXE工程时可能由于系统原因会导致按钮文字显示不全,缺字少字的情况,网上搜了好多帖子,有说DLL文件缺失,有说框体不够大等等,我全都尝试了一遍都没有解决,最后本人使用了一个比较LOW的办法:在按钮Caption属性中输入文字时多加了些空格,终于解决了

    在这里插入图片描述

    部分代码

    代码片如下:.

        Dim excel_App As Excel.Application
        Dim excel_Book As Excel.Workbook
        Dim excel_sheet1 As Excel.Worksheet
        Dim excel_sheet2 As Excel.Worksheet
    Private Sub Form_Load()
    
        Set excel_App = CreateObject("excel.application")
        Set excel_Book = excel_App.Workbooks.Open(App.Path + "\MD5.xls")
        Set excel_sheet1 = excel_Book.Worksheets("sheet1")
        Set excel_sheet2 = excel_Book.Worksheets("sheet2")
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    
    
    
    '    关闭EXCEL
    '    强制回收 Excel 进程
        
        excel_Book.Close (False) '关闭工作簿
    '    int geneID = System.GC.GetGeneration(excel_App)
    '    excel_App.Visible = False
        Set excel_sheet1 = Nothing
        Set excel_sheet2 = Nothing
        Set excel_Book = Nothing
        excel_App.Quit '结束EXCEL对象
        Set excel_App = Nothing '释放xlApp对象
    
    End Sub
    'D-证件号4 E-姓名5 H-秘钥8
    'CStr(excel_sheet1.Cells(2, 4))
    'CStr(excel_sheet1.Cells(2, 5))
    'CStr(excel_sheet1.Cells(2, 8))
    's_MD5str = Module_MD5.MD5("ABC", 32)
    
    Private Sub MD5_Click()
    
    '    重复部分
        Dim strxml_templ As String
    
        strxml_templ = strxml_templ + "IdentNo" + "&"
        strxml_templ = strxml_templ + "ChinNm" + "|"
    
        
    '   循环读取表格参数后进行拼接
        Dim flag As Integer
        Dim strxml_rebody As String
        strxml_rebody = strxml_templ
        flag = 2
        
        For i = 1 To 300
            strxml_rebody = strxml_templ
            strxml_rebody = Replace(strxml_rebody, "IdentNo", CStr(excel_sheet1.Cells(flag, 4)))
            strxml_rebody = Replace(strxml_rebody, "ChinNm", CStr(excel_sheet1.Cells(flag, 5)))
    
            strxml_body = strxml_body + strxml_rebody
            
    '    逻辑判断读取行数
            flag = flag + 1
            
            If Cells(flag, 1) = "" Then
                Exit For
            End If
           
        Next i
    
        strxml_rebody = strxml_body + CStr(excel_sheet1.Cells(2, 8))
        
    '    MsgBox strxml_rebody
    
        s_MD5str = Module_MD5.MD5(strxml_rebody, 32)
        
    ''    关闭EXCEL
    '    excel_Book.Close (False) '关闭工作簿
    '    excel_App.Visible = False
    '    excel_App.Quit '结束EXCEL对象
    '    Set excel_sheet1 = Nothing
    '    Set excel_Book = Nothing
    '    Set excel_App = Nothing '释放xlApp对象
    End Sub
    
    Private Sub Text1_Click()
    
    '选中文本框中全部内容
    'MsgBox "abc"
        With Text1
            .SelStart = 0
            .SelLength = Len(Text1.Text)
            '让文本框获取焦点
            .SetFocus
        End With
    
    End Sub
    
    Private Sub 单笔港澳台居民来往大陆通行证信息核查_Click()
    
    '    Set excel_App = CreateObject("excel.application")
    '    Set excel_Book = excel_App.Workbooks.Open(App.Path + "\MD5.xls")
    '    Set excel_sheet1 = excel_Book.Worksheets("sheet1")
    '    Set excel_sheet2 = excel_Book.Worksheets("sheet2")
        
    '    excel_sheet2.Cells(3, 1) = "TEST"
    
        strxml = "<service>" + Chr(10) + Chr(13)
        
    '    HEAD字符串拼接
        strxml_head = Chr(9) + "<Head>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<SvcCd>" + CStr(excel_sheet2.Cells(2, 1)) + "</SvcCd>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<ChanlCd>" + CStr(excel_sheet2.Cells(2, 2)) + "</ChanlCd>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<Mac />" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<CnsmrSysNo>" + CStr(excel_sheet2.Cells(2, 3)) + "</CnsmrSysNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<CnsmrNodeNo>" + CStr(excel_sheet2.Cells(2, 4)) + "</CnsmrNodeNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<CnsmrSysEgShrtNm>" + CStr(excel_sheet2.Cells(2, 5)) + "</CnsmrSysEgShrtNm>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<TranDt>" + CStr(excel_sheet2.Cells(2, 6)) + "</TranDt>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<TranTm>" + CStr(excel_sheet2.Cells(2, 7)) + "</TranTm>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<MsgVerNo>" + CStr(excel_sheet2.Cells(2, 8)) + "</MsgVerNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<MsgTp>" + CStr(excel_sheet2.Cells(2, 9)) + "</MsgTp>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<SvcVerNo>" + CStr(excel_sheet2.Cells(2, 10)) + "</SvcVerNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<GlbNo>" + CStr(excel_sheet2.Cells(2, 11)) + "</GlbNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<RqsSeqNo>" + CStr(excel_sheet2.Cells(2, 12)) + "</RqsSeqNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<CharSet>utf-8</CharSet>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<DgtSgnDsc>" + CStr(excel_sheet2.Cells(2, 13)) + "</DgtSgnDsc>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<SgnTp>" + CStr(excel_sheet2.Cells(2, 14)) + "</SgnTp>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<UsrLng />" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<InstNo />" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<TlrNo />" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + Chr(9) + "<SrcCnsmrSysNo>" + CStr(excel_sheet2.Cells(2, 15)) + "</SrcCnsmrSysNo>" + Chr(10) + Chr(13)
        strxml_head = strxml_head + Chr(9) + "</Head>" + Chr(10) + Chr(13)
        
    '   BODY字符串拼接
        strxml_body = Chr(9) + "<Body>" + Chr(10) + Chr(13)
        strxml_body = strxml_body + Chr(9) + Chr(9) + "<CustNo1>" + CStr(excel_sheet2.Cells(5, 1)) + "</CustNo1>" + Chr(10) + Chr(13)
        strxml_body = strxml_body + Chr(9) + Chr(9) + "<CustNo2>" + CStr(excel_sheet2.Cells(5, 2)) + "</CustNo2>" + Chr(10) + Chr(13)
        
    '    重复部分
        Dim strxml_templ As String
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<BusTp>BusTpValue</BusTp>" + Chr(10) + Chr(13)
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<CtznTp>CtznTpValue</CtznTp>" + Chr(10) + Chr(13)
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<AreaNo>AreaNoValue</AreaNo>" + Chr(10) + Chr(13)
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<IdentNo>IdentNoValue</IdentNo>" + Chr(10) + Chr(13)
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<ChinNm>ChinNmValue</ChinNm>" + Chr(10) + Chr(13)
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<BrthDt>BrthDtValue</BrthDt>" + Chr(10) + Chr(13)
        strxml_templ = strxml_templ + Chr(9) + Chr(9) + "<IdentVldDt>IdentVldDtValue</IdentVldDt>" + Chr(10) + Chr(13)
        
    '   循环读取表格参数后进行拼接
        Dim flag As Integer
        Dim strxml_rebody As String
        strxml_rebody = strxml_templ
        flag = 2
        
        For i = 1 To 1
            strxml_rebody = strxml_templ
            strxml_rebody = Replace(strxml_rebody, "BusTpValue", CStr(excel_sheet1.Cells(flag, 1)))
            strxml_rebody = Replace(strxml_rebody, "CtznTpValue", CStr(excel_sheet1.Cells(flag, 2)))
            strxml_rebody = Replace(strxml_rebody, "AreaNoValue", CStr(excel_sheet1.Cells(flag, 3)))
            strxml_rebody = Replace(strxml_rebody, "IdentNoValue", CStr(excel_sheet1.Cells(flag, 4)))
            strxml_rebody = Replace(strxml_rebody, "ChinNmValue", CStr(excel_sheet1.Cells(flag, 5)))
            strxml_rebody = Replace(strxml_rebody, "BrthDtValue", CStr(excel_sheet1.Cells(flag, 6)))
            strxml_rebody = Replace(strxml_rebody, "IdentVldDtValue", CStr(excel_sheet1.Cells(flag, 7)))
            strxml_body = strxml_body + strxml_rebody
            
    '    逻辑判断读取行数
            flag = flag + 1
            
            If Cells(flag, 1) = "" Then
                Exit For
            End If
           
        Next i
    
        strxml_body = strxml_body + Chr(9) + "</Body>" + Chr(10) + Chr(13)
    
        strxml = strxml + strxml_head + strxml_body + "</service>"
    
    '    设置单元格的值,输出生成的XLM
    '    Sheets("公民身份证件信息核查").TextBox1.Text = strxml
        s_MD5str = strxml
        
    '    '    关闭EXCEL
    '    excel_Book.Close (False) '关闭工作簿
    '    excel_App.Visible = False
    '    excel_App.Quit '结束EXCEL对象
    '    Set excel_sheet1 = Nothing
    '    Set excel_sheet2 = Nothing
    '    Set excel_Book = Nothing
    '    Set excel_App = Nothing '释放xlApp对象
    End Sub
    
    Private Sub 确定生成_Click()
    'MsgBox MD5("ABC", 32)
    'cell_1 = CStr(Cells(2, 1))
    'cell_2 = CStr(Cells(2, 2))
    'cell_3 = CStr(Cells(2, 3))
    'cell_4 = CStr(Cells(2, 4))
    'cell_5 = CStr(Cells(2, 5))
    'cell_6 = CStr(Cells(2, 6))
    'cell_7 = CStr(Cells(2, 7))
    'cell_8 = CStr(Cells(2, 8))
    
    'MsgBox s_MD5str
    
    Text1.Text = s_MD5str
    
    End Sub
    

    使用VB进行MD5加密的代码

    这里不用纠结于代码中的具体算法了,只需要调用下面代码即可,例:Module_MD5.MD5(strxml_rebody, 32)

    Private Const BITS_TO_A_BYTE = 8
    Private Const BYTES_TO_A_WORD = 4
    Private Const BITS_TO_A_WORD = 32
     
    Private m_lOnBits(30)
    Private m_l2Power(30)
     
    Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
    LShift = lValue
    Exit Function
    ElseIf iShiftBits = 31 Then
    If lValue And 1 Then
    LShift = &H80000000
    Else
    LShift = 0
    End If
    Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
    Err.Raise 6
    End If
     
    If (lValue And m_l2Power(31 - iShiftBits)) Then
    LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
    Else
    LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
    End Function
     
    Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
    RShift = lValue
    Exit Function
    ElseIf iShiftBits = 31 Then
    If lValue And &H80000000 Then
    RShift = 1
    Else
    RShift = 0
    End If
    Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
    Err.Raise 6
    End If
     
    RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
     
    If (lValue And &H80000000) Then
    RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
    End If
    End Function
     
    Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
    End Function
     
    Private Function AddUnsigned(lX, lY)
    Dim lX4
    Dim lY4
    Dim lX8
    Dim lY8
    Dim lResult
     
    lX8 = lX And &H80000000
    lY8 = lY And &H80000000
    lX4 = lX And &H40000000
    lY4 = lY And &H40000000
     
    lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
     
    If lX4 And lY4 Then
    lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
    ElseIf lX4 Or lY4 Then
    If lResult And &H40000000 Then
    lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
    Else
    lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
    End If
    Else
    lResult = lResult Xor lX8 Xor lY8
    End If
     
    AddUnsigned = lResult
    End Function
     
    Private Function md5_F(x, y, z)
    md5_F = (x And y) Or ((Not x) And z)
    End Function
     
    Private Function md5_G(x, y, z)
    md5_G = (x And z) Or (y And (Not z))
    End Function
     
    Private Function md5_H(x, y, z)
    md5_H = (x Xor y Xor z)
    End Function
     
    Private Function md5_I(x, y, z)
    md5_I = (y Xor (x Or (Not z)))
    End Function
     
    Private Sub md5_FF(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
    End Sub
     
    Private Sub md5_GG(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
    End Sub
     
    Private Sub md5_HH(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
    End Sub
     
    Private Sub md5_II(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
    End Sub
     
    Private Function ConvertToWordArray(sMessage)
    Dim lMessageLength
    Dim lNumberOfWords
    Dim lWordArray()
    Dim lBytePosition
    Dim lByteCount
    Dim lWordCount
     
    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448
     
    lMessageLength = Len(sMessage)
     
    lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)
     
    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
    lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
    lByteCount = lByteCount + 1
    Loop
     
    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
     
    lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
     
    lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
     
    ConvertToWordArray = lWordArray
    End Function
     
    Private Function WordToHex(lValue)
    Dim lByte
    Dim lCount
     
    For lCount = 0 To 3
    lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
    WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
    Next
    End Function
     
    Public Function MD5(sMessage, stype)
    m_lOnBits(0) = CLng(1)
    m_lOnBits(1) = CLng(3)
    m_lOnBits(2) = CLng(7)
    m_lOnBits(3) = CLng(15)
    m_lOnBits(4) = CLng(31)
    m_lOnBits(5) = CLng(63)
    m_lOnBits(6) = CLng(127)
    m_lOnBits(7) = CLng(255)
    m_lOnBits(8) = CLng(511)
    m_lOnBits(9) = CLng(1023)
    m_lOnBits(10) = CLng(2047)
    m_lOnBits(11) = CLng(4095)
    m_lOnBits(12) = CLng(8191)
    m_lOnBits(13) = CLng(16383)
    m_lOnBits(14) = CLng(32767)
    m_lOnBits(15) = CLng(65535)
    m_lOnBits(16) = CLng(131071)
    m_lOnBits(17) = CLng(262143)
    m_lOnBits(18) = CLng(524287)
    m_lOnBits(19) = CLng(1048575)
    m_lOnBits(20) = CLng(2097151)
    m_lOnBits(21) = CLng(4194303)
    m_lOnBits(22) = CLng(8388607)
    m_lOnBits(23) = CLng(16777215)
    m_lOnBits(24) = CLng(33554431)
    m_lOnBits(25) = CLng(67108863)
    m_lOnBits(26) = CLng(134217727)
    m_lOnBits(27) = CLng(268435455)
    m_lOnBits(28) = CLng(536870911)
    m_lOnBits(29) = CLng(1073741823)
    m_lOnBits(30) = CLng(2147483647)
     
    m_l2Power(0) = CLng(1)
    m_l2Power(1) = CLng(2)
    m_l2Power(2) = CLng(4)
    m_l2Power(3) = CLng(8)
    m_l2Power(4) = CLng(16)
    m_l2Power(5) = CLng(32)
    m_l2Power(6) = CLng(64)
    m_l2Power(7) = CLng(128)
    m_l2Power(8) = CLng(256)
    m_l2Power(9) = CLng(512)
    m_l2Power(10) = CLng(1024)
    m_l2Power(11) = CLng(2048)
    m_l2Power(12) = CLng(4096)
    m_l2Power(13) = CLng(8192)
    m_l2Power(14) = CLng(16384)
    m_l2Power(15) = CLng(32768)
    m_l2Power(16) = CLng(65536)
    m_l2Power(17) = CLng(131072)
    m_l2Power(18) = CLng(262144)
    m_l2Power(19) = CLng(524288)
    m_l2Power(20) = CLng(1048576)
    m_l2Power(21) = CLng(2097152)
    m_l2Power(22) = CLng(4194304)
    m_l2Power(23) = CLng(8388608)
    m_l2Power(24) = CLng(16777216)
    m_l2Power(25) = CLng(33554432)
    m_l2Power(26) = CLng(67108864)
    m_l2Power(27) = CLng(134217728)
    m_l2Power(28) = CLng(268435456)
    m_l2Power(29) = CLng(536870912)
    m_l2Power(30) = CLng(1073741824)
     
     
    Dim x
    Dim k
    Dim AA
    Dim BB
    Dim CC
    Dim DD
    Dim a
    Dim b
    Dim c
    Dim d
     
    Const S11 = 7
    Const S12 = 12
    Const S13 = 17
    Const S14 = 22
    Const S21 = 5
    Const S22 = 9
    Const S23 = 14
    Const S24 = 20
    Const S31 = 4
    Const S32 = 11
    Const S33 = 16
    Const S34 = 23
    Const S41 = 6
    Const S42 = 10
    Const S43 = 15
    Const S44 = 21
     
    x = ConvertToWordArray(sMessage)
     
    a = &H67452301
    b = &HEFCDAB89
    c = &H98BADCFE
    d = &H10325476
     
    For k = 0 To UBound(x) Step 16
    AA = a
    BB = b
    CC = c
    DD = d
     
    md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478
    md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756
    md5_FF c, d, a, b, x(k + 2), S13, &H242070DB
    md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
    md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
    md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A
    md5_FF c, d, a, b, x(k + 6), S13, &HA8304613
    md5_FF b, c, d, a, x(k + 7), S14, &HFD469501
    md5_FF a, b, c, d, x(k + 8), S11, &H698098D8
    md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
    md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
    md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE
    md5_FF a, b, c, d, x(k + 12), S11, &H6B901122
    md5_FF d, a, b, c, x(k + 13), S12, &HFD987193
    md5_FF c, d, a, b, x(k + 14), S13, &HA679438E
    md5_FF b, c, d, a, x(k + 15), S14, &H49B40821
     
    md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562
    md5_GG d, a, b, c, x(k + 6), S22, &HC040B340
    md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51
    md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
    md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D
    md5_GG d, a, b, c, x(k + 10), S22, &H2441453
    md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681
    md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
    md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
    md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6
    md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87
    md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED
    md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905
    md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
    md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9
    md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
     
    md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942
    md5_HH d, a, b, c, x(k + 8), S32, &H8771F681
    md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122
    md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C
    md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
    md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
    md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
    md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
    md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6
    md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA
    md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085
    md5_HH b, c, d, a, x(k + 6), S34, &H4881D05
    md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039
    md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
    md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
    md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665
     
    md5_II a, b, c, d, x(k + 0), S41, &HF4292244
    md5_II d, a, b, c, x(k + 7), S42, &H432AFF97
    md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7
    md5_II b, c, d, a, x(k + 5), S44, &HFC93A039
    md5_II a, b, c, d, x(k + 12), S41, &H655B59C3
    md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92
    md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D
    md5_II b, c, d, a, x(k + 1), S44, &H85845DD1
    md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F
    md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
    md5_II c, d, a, b, x(k + 6), S43, &HA3014314
    md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1
    md5_II a, b, c, d, x(k + 4), S41, &HF7537E82
    md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235
    md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
    md5_II b, c, d, a, x(k + 9), S44, &HEB86D391
     
    a = AddUnsigned(a, AA)
    b = AddUnsigned(b, BB)
    c = AddUnsigned(c, CC)
    d = AddUnsigned(d, DD)
    Next
     
    If stype = 32 Then
    MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
    Else
    MD5 = LCase(WordToHex(b) & WordToHex(c))
    End If
    End Function
    Sub test()
    MsgBox MD5("a", 16) '16位加密
    MsgBox MD5("a", 32) '32位加密
    End Sub
    
    展开全文
  • 但不是什么都能全自动化的,如果数据的输入都是excel,而且还要能方便的在所有人的机器上跑,那基于excelVB来实现一些简单数据处理也是非常方便的。 咳咳,扯远了。这章总结的是,如何从一个固定格式的工作表A,...

    问题背景

    如果一切数据都跑在后台,数据之间的迁移在全部自动化的情况下,无疑使用csv+python等处理更理想。但不是什么都能全自动化的,如果数据的输入都是excel,而且还要能方便的在所有人的机器上跑,那基于excel的VB来实现一些简单数据处理也是非常方便的。
    咳咳,扯远了。这章总结的是,如何从一个固定格式的工作表A,提取出想要的数据,按自己设定好的格式,写入另一个工作表B。

    设计思路

    1、需要掌握的技能

    1. 需要掌握获取文件路径、文件的打开和关闭等文件操作(实际实现时我都是ctrl+A全选然后ctrl+V贴到专门准备好的一个工作表里,怎么方便怎么来了)
    2. 需要知道怎么一行行/一列列地遍历指定工作表的有效数据,核心是,用For循环,循环条件是有效行的行号/列号
    3. 知道行号/列号,能方便的读写该行/列任意单元格的值
    4. 用IF ELSE对获取到的值进行条件处理

    2、实现逻辑

    1. For循环,遍历源文件A的标志数据列[A]
    2. IF条件检查[A]的值"aa"的有效性,满足条件则准备处理目标文件B
    3. For循环,遍历目标文件B的目标数据列[B]
    4. IF条件检查[B]的整列值里是否包含"aa",包含则按同类项累加,不包含则遍历结束后新增"aa"行
    5. 根据实际情况,步骤2和4会增加一定复杂度,但总体逻辑都可以拆分为1~4步骤的结合

    模块功能实现

    1. VBA文件路径获取、文件的打开、关闭
    Sub DemoFileOp()
    
    Dim WbookSrc
    
    paths = ThisWorkbook.Path & "\"        '获取当前路径
    Set WbookSrc = Workbooks.Open(paths & "Src.xlsx")  '打开源excel文件
    ......
    '关闭释放内存,否则高频操作excel会挂
    WbookSrc.Quit Save:=True  '保存excel
    Set WbookSrc = Nothing      '释放内存
    
    End Sub
    

    PS: 如果输入输出不是多个文件,一般来说手动复制源数据到工作表里会更方便。这个只是我一开始查到可以这么玩,实际操作把这块砍掉了。这里放着看以后有需要的时候再捡起来。

    1. VBA For循环对数据行/列遍历
    '****************************** 遍历行 ******************************
    Sub DemoForRow()
    
    Dim SrcRcdNum
    
    For SrcRcdNum = 2 To ThisWorkBook.Worksheets(1).Range("A65536").End(xlUp).Row  '遍历A列
       On Error Resume Next    '出了异常继续
       MsgBox Range("A" & SrcRcdNum)    '通过Range获取数据
       If ThisWorkbook.Worksheets(1).Range("A" & SrcRcdNum) = "aa"  Then    'For循环的条件退出
       	Exit For
       End If
    Next
    
    End Sub
    '****************************** 遍历列 ******************************
    Sub DemoForColumn()
    
    Dim SrcColNum
    
    For SrcColNum = 1 To ThisWorkbook.Worksheets(1).Range("AZ2").End(xlToLeft).Column  '遍历第2行
       If ThisWorkbook.Worksheets(1).Cells(2, SrcColNum) = "aa" Then   '列遍历使用Cells(行号,列号),避免数值和字母的转换
       	Exit For
       End If
    Next
    
    End Sub
    

    PS: VB的格式没有严格的缩进,但我觉得最好按python的习惯去写。

    1. 根据行号、列号获取单元格的值
    Range("A" & SrcRcdNum)    '通过Range获取数据,需要"A65535"这样的字符串表示的单元格
    Cells(2, SrcColNum)     '通过Cells获取数据,需要按(行号,列号)填充数据,如Cells(1,2)表示"B1"
    
    1. 用IF ELSE进行条件处理
    If "OK" = ThisWorkbook.Worksheets(1).Range("E" & SrcRcdNum) Then  
    	Flag = 1
    ElseIf "Pending" = ThisWorkbook.Worksheets(1).Range("E" & SrcRcdNum) Then
    	Flag = 2
    Else
    	Flag = 255
    End If
    

    PS: 对于多种情况的处理,比较清晰的方式是用标志位,等跳出循环后,再按标志位的值处理(扩展性好)。跳出循环时,行号列号仍是保留的。

    DEMO

    这里要实现的是,根据系统导出的昨日订单数据(每行源数据含订单号、产品编码、产品名称、订单状态、产品数量),生成产品每日销量表。

    Sub UpdateOrder()
    
    '定义VBA工作表操作相关的变量
    Dim SrcRcdNum
    Dim DstRcdNum
    Dim ExistFlag    
    
    '****************************** UpdateOrder ******************************
    '根据订单生成销售数据
    For SrcRcdNum = 2 To ThisWorkbook.Worksheets("昨日订单").Range("A65536").End(xlUp).Row  '遍历Src A列,所有订单号
    
    	'标志位清零
    	ExistFlag = 0
    	On Error Resume Next    '出了异常继续
    
    	For DstRcdNum = 2 To ThisWorkbook.Worksheets("生成数据").Range("A65536").End(xlUp).Row  '遍历Dst 产品编码列
    
    		If ThisWorkbook.Worksheets("昨日订单").Range("B" & SrcRcdNum) = ThisWorkbook.Worksheets("生成数据").Range("A" & DstRcdNum) Then '产品编码相等,记下该行,跳出循环
    			ExistFlag = 1             '产品编码相等,flag = 1
    			Exit For 
    		End If
    	Next
    	
    	'根据flag标志进行目的文件更新
    	
    	'ExistFlag = 0, 产品编码不存在,全部新建数据
    	If ExistFlag = 0 Then
    		ThisWorkbook.Worksheets("生成数据").Range("A" & DstRcdNum) = ThisWorkbook.Worksheets("昨日订单").Range("B" & SrcRcdNum) '产品编码
    		ThisWorkbook.Worksheets("生成数据").Range("B" & DstRcdNum) = ThisWorkbook.Worksheets("昨日订单").Range("C" & SrcRcdNum) '产品名称
    		
    		'根据Cancelled判断是不是有效订单
    		If "Cancelled" <> ThisWorkbook.Worksheets("昨日订单").Range("D" & SrcRcdNum) Then  'Src D列,订单状态
    			ThisWorkbook.Worksheets("生成数据").Range("C" & DstRcdNum) = ThisWorkbook.Worksheets("昨日订单").Range("E" & SrcRcdNum) 'Src E列,产品销售的数量
    		Else
    			ThisWorkbook.Worksheets("生成数据").Range("D" & DstRcdNum) = 1 '取消订单的次数
    		End If
    	'ExistFlag = 1, 存在产品编码,累加数据
    	ElseIf ExistFlag = 1 Then
    		If "Cancelled" <> ThisWorkbook.Worksheets("昨日订单").Range("E" & SrcRcdNum) Then
    			ThisWorkbook.Worksheets("生成数据").Range("C" & DstRcdNum) = ThisWorkbook.Worksheets("生成数据").Range("C" & DstRcdNum) + ThisWorkbook.Worksheets("昨日订单").Range("E" & SrcRcdNum)  '数量叠加
    		Else
    			ThisWorkbook.Worksheets("生成数据").Range("D" & DstRcdNum) = ThisWorkbook.Worksheets("生成数据").Range("D" & DstRcdNum) + 1 '累加取消订单的次数
    		End If
    	End If
    
    Next
    
    End Sub
    

    扩展

    1.动态比较日期

    月度销量汇总的话,需要根据当前日期去匹配总表里的日期,才知道要更新哪列。
    在单元格Cells(2,2)设定值为=NOW(),再设置单元格格式为"3月14日",即忽略时分秒。
    实际比较中,NOW函数获取到的系统时间,整数位表示年月日,小数位表示时分秒,我们"ctrl+:"指定的日期是只有年月日的,在比较前需要对Cells(2,2)做取整处理。对了,时间虽然可以调格式显示成字符,实际应该仍是数值。
    在这里插入图片描述

    ...  '获取匹配今日的列号
    For DstRcdNum = 7 To ThisWorkbook.Worksheets(1).Range("AZ3").End(xlToLeft).Column  '遍历第3行,汇总表一般不超过1个月,AZ够了
    If ThisWorkbook.Worksheets(1).Cells(3, DstRcdNum) = Fix(ThisWorkbook.Worksheets(1).Cells(2, 3)) Then '比较日期,是否为今日
    TodayColumn = DstRcdNum
    Exit For
    End If
    Next
    ...
    

    2.条件格式高亮单元格

    当某日库存小于某个周期的销量时,最好能高亮该产品,以提醒发货。
    在这里插入图片描述
    找到条件格式新建一个规则,比较大小,满足条件则填充指定颜色即可。
    开始 - 样式 - 条件格式 - 新建规则
    按公式,选两个目标单元格比较,然后指定应用范围。
    在这里插入图片描述
    有时想按指定的行号高亮单元格,比如奇偶行高亮,每隔10行高亮等等,方便查看数据。
    可以按以下公式设置条件格式:

    公式:    =MOD(ROUNDUP((ROW()-1)/11,0),2)=1    #这里是每隔11行满足一次条件
    

    在这里插入图片描述
    MOD:取余函数,第一参数是除数,第二参数是被除数,这里套用奇偶行高亮规则,只要余数=1就高亮
    ROUNDUP:进一取整函数,第一参数是带小数的数,第二参数是要保留的小数位,第二参数取0,实现进一取整
    ROW:获取行号,第一行是标题,所以减1,我要按11行高亮,所以除以11
    效果如下:
    在这里插入图片描述

    3.动态获取周期范围的值

    诉求是能根据当前日期动态的获取7日销量的数据。
    由于这些数据都是显式呈现在excel上,只需要简单求和,难的是根据日期去匹配指定的列号。
    这个表是一个月备一次,1号到31号的列号其实是固定的。以1号为基准列号,可以根据今日日期的值减去1号的值得到今日日期和1号日期的列号差,用1号的基准列号加上这个差值就能得到今日数据所在的列号。

    假设F34是任意一个产品,I20是X月1号的日期,C2是=NOW()(当前日期)
    获取今日该产品销量所在单元格的值:
    =INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)))

    说明:Address获取某个产品的行号,列号由X月1号的列号加上列号差得到

    获取到1天,7日的就是逐级往左取值。

    =INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)))+IF(INT(C2-I20)-1>0, INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)-1)), 0)+IF(INT(C2-I20)-2>0,INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)-2)), 0)+IF(INT(C2-I20)-3>0,INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)-3)), 0)+IF(INT(C2-I20)-4>0,INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)-4)), 0)+IF(INT(C2-I20)-5>0,INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)-5)), 0)+IF(INT(C2-I20)-6>0,INDIRECT(ADDRESS(CELL(“row”,F34),CELL(“col”,I20)+INT(C2-I20)-6)), 0)

    展开全文
  • VB.NET 自动提取Excel 数据程序
  • 一段用VB读取EXCEL数据的代码,下下来自己稍做改动就可以用了,很方便的。。。。
  • 从word表格中提取数据excel表格,可以批量提取数据自动导入的excel表格。
  • vb编程遍历Excel中所有单元格,读取出所有单元格内容
  • 是给朋友整理实验数据用的,两个小需求:一、要第一列是数据序号,且多个文件数据拷到目的文件的时候数据序号要按顺序排列;二、每个文件可能有多个worksheet,都要拷贝到目标文件里面。对于office2003以前的excel,...

    是给朋友整理实验数据用的,两个小需求:

    一、要第一列是数据序号,且多个文件数据拷到目的文件的时候数据序号要按顺序排列;

    二、每个文件可能有多个worksheet,都要拷贝到目标文件里面。

    对于office2003以前的excel,是支持Application.FileSearch的,实现代码如下:

    Sub Test()

    Dim i As Integer,iRow As Integer

    Dim strPath As String

    Dim TheSheet As Worksheet

    iRow = 1

    Set TheSheet = ActiveWorkbook.Worksheets("sheet1")

    strPath = "D:/Macro/testtest"

    With Application.FileSearch

    .LookIn = strPath

    .SearchSubFolders = True

    .Filename = "*.*"

    If .Execute > 0 Then

    For i = 1 To .FoundFiles.Count

    'Range("A" & i) = .FoundFiles(i)

    Workbooks.Open (.FoundFiles(i))

    For j = 1 To ActiveWorkbook.Worksheets.Count

    'ActiveWorkbook.Worksheets(i).Cells(1,1).Value = "a"

    ActiveWorkbook.Worksheets(j).UsedRange.Copy

    TheSheet.Activate

    While TheSheet.Range("a" & iRow).Value <> ""

    TheSheet.Cells(iRow,1) = iRow

    iRow = iRow + 1

    Wend

    TheSheet.Range("A" & iRow).Select

    ActiveSheet.Paste

    ActiveWorkbook.Save

    Next j

    Workbooks(Workbooks.Count).Close

    Next i

    End If

    End With

    End Sub

    --------------------------------------------------------------------------------------

    对于Office2007的用户,Application.FileSearch不支持了,修改后的代码如下:

    Sub Test()

    Dim i As Integer,iRow As Integer

    Dim strPath,Filename,Search_Fullname As String

    Dim TheSheet,CurrentSheet As Worksheet

    Dim Coll_Docs As New Collection

    Dim activeSheetName As String

    iRow = 1

    Set TheSheet = ActiveWorkbook.Worksheets("sheet1")

    strPath = "D:/Macro/testtest"

    Filename = "*.xls"

    Set Coll_Docs = Nothing

    DocName = Dir(strPath & "/" & Filename)

    Do Until DocName = ""

    Coll_Docs.Add Item:=DocName

    DocName = Dir

    Loop

    For i = Coll_Docs.Count To 1 Step -1

    Search_Fullname = strPath & "/" & Coll_Docs(i)

    Workbooks.Open (Search_Fullname)

    For j = 1 To ActiveWorkbook.Worksheets.Count Step 1

    If j = 1 Then

    activeSheetName = "sheet" & j

    Set CurrentSheet = ActiveWorkbook.Worksheets(activeSheetName)

    End If

    CurrentSheet.Activate

    ActiveWorkbook.Worksheets(j).UsedRange.Copy

    TheSheet.Activate

    While TheSheet.Range("a" & iRow).Value <> ""

    TheSheet.Cells(iRow,1) = iRow

    iRow = iRow + 1

    Wend

    TheSheet.Range("A" & iRow).Select

    ActiveSheet.Paste

    ActiveWorkbook.Save

    Next j

    Workbooks(Workbooks.Count).Close

    Next i

    End Sub

    展开全文
  • 数据导出到Excel的6种方法(VB6)

    千次阅读 2020-02-12 12:48:04
    数据导出到Excel的6种方法(VB6) 在数据操作中,特别是与数据库相关的操作中,我们需要经常导出数据Excel表格中,下面我们提供了六种方式来将数据导出到Excel表格中: 如果大家C币比较多的话,可以直接下载我整理好...

    数据导出到Excel的6种方法(VB6)

    在数据操作中,特别是与数据库相关的操作中,我们需要经常导出数据到Excel表格中,下面我们提供了六种方式来将数据导出到Excel表格中:
    如果大家C币比较多的话,可以直接下载我整理好的源码:点击此处下载>>>>
    六种导入数据到Excel的方法
    此实例提供了6种导出数据到Excel的方法,说明如下:
    1.通过获取Excel对象,然后使用Excel的QueryTable方法生成数据到Excel表指定位置,速度比较快
    代码如下::

    	Dim xlApp As New Excel.Application
        Dim xlQuery As Excel.QueryTable
        Dim xlSheet As Worksheet
        Dim SQL As String
        On Error GoTo Err_Cmd_QueryTable_Click
        '-------------------------------------
        ConnMDB
        If RS.State Then RS.Close
        Set xlApp = New Excel.Application    '初始化对象变量
        xlApp.SheetsInNewWorkbook = 1  '将新建的工作薄数量设为1
        xlApp.Workbooks.Add          '增加一个工作薄
        xlApp.Sheets(xlApp.Sheets.Count).Name = "QueryTable技术导出记录集"  '修改工作薄名称
        Set xlSheet = xlApp.Worksheets("QueryTable技术导出记录集")
        SQL = "select * from student"
        Query2Excel SQL, Cnn, xlSheet, "A1", xlQuery 'A1即可将数据放到A1单元格
          '删除产生的连接
          Dim i As Long
        For i = xlSheet.Application.ActiveWorkbook.Connections.Count To 1 Step -1
            xlSheet.Application.ActiveWorkbook.Connections(i).Delete
        Next i
        xlApp.Visible = True
        xlApp.Application.Visible = True
        Set xlApp = Nothing  '"交还控制给Excel
        Set xlSheet = Nothing
        '-------------------------------------
       On Error GoTo 0
       Exit Sub
    Err_Cmd_QueryTable_Click:
       If MsgBox("【版本信息】:" & 版本 & vbCrLf & "【错误代码】:" & Err.Number & vbCrLf & "【错误描述】:" & Err.Description & vbCrLf & "【出错位置】: [Form1]→ [Cmd_QueryTable_Click]的 " & Erl & "" & vbCrLf & "是否继续?", vbYesNo + vbQuestion + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    

    其中ConnMDB及Query2Excel函数如下
    代码如下:

    Public Cnn As New ADODB.Connection
    Public RS As New ADODB.Recordset
    Public RStmp As New ADODB.Recordset
    Public FilePath As String
    '连接本地Access数据库
    Public Function ConnMDB() As Boolean
        Dim ConnStr As String
        If Cnn.State Then Cnn.Close
        ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=true;Persist Security Info=True;Data Source=" & App.Path & "\data.mdb"
        Cnn.CursorLocation = adUseClient
        Cnn.Open ConnStr
        If Cnn.State = 0 Then
            MsgBox "连接本地数据库失败,系统自动退出.", vbOKOnly + vbInformation, "信息提示"
        Else
            ConnMDB = True
        End If
    End Function
    '连接本地excel文件
    Public Function ConnExcel() As Boolean
        Dim ConnStr As String
        FilePath = "data.xls"
        If ExcelVer(FilePath) = 3 Then
            'excel 2003
            ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & App.Path & "\" & FilePath & ";Extended Properties=""Excel 8.0;HDR=yes;IMEX=1"""
        Else
            'excel 2007,2010,2013,2016
            ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & App.Path & "\" & FilePath & ";Extended Properties=""Excel 12.0;HDR=yes;IMEX=1"""
        End If
        If Cnn.State Then Cnn.Close
        Cnn.Open ConnStr
        If Cnn.State = 0 Then
            MsgBox "连接本地Excel失败,系统自动退出.", vbOKOnly + vbInformation, "信息提示"
        Else
            ConnExcel = True
        End If
    End Function
    Public Function Query2Excel(SQL As String, CN As ADODB.Connection, xlSheet As Excel.Worksheet, InsertPosition As String, xlQuery As Excel.QueryTable)
        If RStmp.State Then RStmp.Close
        RStmp.CursorLocation = adUseClient
        RStmp.Open SQL, CN, adOpenStatic, adLockReadOnly
        If RStmp.RecordCount < 1 Then
            Exit Function
        End If
        '添加查询语句,导入EXCEL数据
        Set xlQuery = xlSheet.QueryTables.Add(RStmp, xlSheet.Range(InsertPosition))
        With xlQuery
            .FieldNames = True
            .FieldNames = False    '是否显示字段名
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertEntireRows
            .SavePassword = True
            .SaveData = False
            .AdjustColumnWidth = False    '不需要列宽
            .RefreshPeriod = 0
            .PreserveColumnInfo = True
        End With
        xlQuery.Refresh
    End Function
    Public Function ExcelVer(ST As String) As Long
        Dim 后缀 As String
        后缀 = Mid(ST, InStrRev(ST, ".") + 1)
        ExcelVer = Len(后缀)
    End Function
    

    2.通过连接Access创建选择集,然后将选择集批量插入Excel指定位置,速度比较快
    代码如下:

        Dim xlApp As New Excel.Application
        Dim xlSheet As Worksheet
        Dim SQL As String
        On Error GoTo Err_Cmd_ADO_AccessDB_Click
        '-------------------------------------
        ConnMDB
        If RS.State Then RS.Close
        Set xlApp = New Excel.Application    '初始化对象变量
        xlApp.SheetsInNewWorkbook = 1  '将新建的工作薄数量设为1
        xlApp.Workbooks.Add          '增加一个工作薄
        xlApp.Sheets(xlApp.Sheets.Count).Name = "连接Access导出数据实例"  '修改工作薄名称
        Set xlSheet = xlApp.Worksheets("连接Access导出数据实例")
        xlSheet.SaveAs App.Path & "\" & Format(Now, "yyyy-MM-dd-hh_mm_ss") & "学生表.xls"
        SQL = "select * from student"
        xlSheet.Cells(1, 1).CopyFromRecordset Cnn.Execute(SQL)
        Cnn.Close
        xlSheet.Application.ActiveWorkbook.Save
        xlApp.Visible = True
        xlApp.Application.Visible = True
        Set xlApp = Nothing  '"交还控制给Excel
        Set xlSheet = Nothing
        '-------------------------------------
       On Error GoTo 0
       Exit Sub
    Err_Cmd_ADO_AccessDB_Click:
       If MsgBox("【版本信息】:" & 版本 & vbCrLf & "【错误代码】:" & Err.Number & vbCrLf & "【错误描述】:" & Err.Description & vbCrLf & "【出错位置】: [Form1]→ [Cmd_ADO_AccessDB_Click]的 " & Erl & "" & vbCrLf & "是否继续?", vbYesNo + vbQuestion + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    

    3.通过连接Excel表,将Excel表作为数据库,创建选择集,然后将选择集批量插入Excel指定位置,速度比较快
    代码如下:

        Dim xlApp As New Excel.Application
        Dim xlSheet As Worksheet
        Dim SQL As String
        On Error GoTo Err_Cmd_ADO_ExcelDB_Click
        '-------------------------------------
        ConnExcel
        If RS.State Then RS.Close
        Set xlApp = New Excel.Application    '初始化对象变量
        xlApp.SheetsInNewWorkbook = 1  '将新建的工作薄数量设为1
        xlApp.Workbooks.Add          '增加一个工作薄
        xlApp.Sheets(xlApp.Sheets.Count).Name = "Excel表格作为数据库导出数据实例"  '修改工作薄名称
        Set xlSheet = xlApp.Worksheets("Excel表格作为数据库导出数据实例")
    '    xlSheet.SaveAs App.Path & "\" & Format(Now, "yyyy-MM-dd-hh_mm_ss") & "学生表.xls"
        SQL = "select * from `学生记录$`"
        xlSheet.Cells(1, 1).CopyFromRecordset Cnn.Execute(SQL)
        Cnn.Close
    '    xlSheet.Application.ActiveWorkbook.Save
        xlApp.Visible = True
        xlApp.Application.Visible = True
        Set xlApp = Nothing  '"交还控制给Excel
        Set xlSheet = Nothing
        '-------------------------------------
       On Error GoTo 0
       Exit Sub
    Err_Cmd_ADO_ExcelDB_Click:
       If MsgBox("【版本信息】:" & 版本 & vbCrLf & "【错误代码】:" & Err.Number & vbCrLf & "【错误描述】:" & Err.Description & vbCrLf & "【出错位置】: [Form1]→ [Cmd_ADO_ExcelDB_Click]的 " & Erl & "" & vbCrLf & "是否继续?", vbYesNo + vbQuestion + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    

    4.将数组直接插入到Excel指定位置,速度比较快,因为数组数据在内存中,对于比较复杂的判断,可以先在数组中处理,可以用此种方法导出
    代码如下:

      Dim xlApp As New Excel.Application
        Dim xlSheet As Worksheet
        On Error GoTo Err_Cmd_From_Arr_Click
        '-------------------------------------
        ConnExcel
        If RS.State Then RS.Close
        Set xlApp = New Excel.Application    '初始化对象变量
        xlApp.SheetsInNewWorkbook = 1  '将新建的工作薄数量设为1
        xlApp.Workbooks.Add          '增加一个工作薄
        xlApp.Sheets(xlApp.Sheets.Count).Name = "直接将内存中的数字复制到Excel实例"  '修改工作薄名称
        Set xlSheet = xlApp.Worksheets("直接将内存中的数字复制到Excel实例")
    
    
        Dim ArrData(10000, 10) As String
        For i = 1 To 10000
            For j = 1 To 10
                ArrData(i, j) = "第" & i & "行,第" & j & "列"
            Next j
        Next i
        xlSheet.Range("B2").Resize(UBound(ArrData, 1), UBound(ArrData, 2)) = ArrData'直接一句话搞定
        xlSheet.Cells.EntireColumn.AutoFit '自动调节列宽
        
        
        xlApp.Visible = True
        xlApp.Application.Visible = True
        Set xlApp = Nothing  '"交还控制给Excel
        Set xlSheet = Nothing
        '-------------------------------------
       On Error GoTo 0
       Exit Sub
    Err_Cmd_From_Arr_Click:
       If MsgBox("【版本信息】:" & 版本 & vbCrLf & "【错误代码】:" & Err.Number & vbCrLf & "【错误描述】:" & Err.Description & vbCrLf & "【出错位置】: [Form1]→ [Cmd_From_Arr_Click]的 " & Erl & "" & vbCrLf & "是否继续?", vbYesNo + vbQuestion + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    

    5.传统的方法,就是向Excel表格对应的单元格一个一个插入数据,此种方法是最原始的,也是最慢的
    代码如下:

     Dim xlApp As New Excel.Application
        Dim xlSheet As Worksheet
        On Error GoTo Err_Cmd_StandardMode_Click
        '-------------------------------------
        ConnExcel
        If RS.State Then RS.Close
        Set xlApp = New Excel.Application    '初始化对象变量
        xlApp.SheetsInNewWorkbook = 1  '将新建的工作薄数量设为1
        xlApp.Workbooks.Add          '增加一个工作薄
        xlApp.Sheets(xlApp.Sheets.Count).Name = "直接写入数据到Excel单元格实例"  '修改工作薄名称
        Set xlSheet = xlApp.Worksheets("直接写入数据到Excel单元格实例")
         Dim ArrData(100, 10) As String
        For i = 1 To 100
            For j = 1 To 10
                xlSheet.Cells(i + 1, j + 1) = "第" & i & "行,第" & j & "列"
            Next j
        Next i
        xlSheet.Cells.EntireColumn.AutoFit '自动调节列宽
        
        
        xlApp.Visible = True
        xlApp.Application.Visible = True
        Set xlApp = Nothing  '"交还控制给Excel
        Set xlSheet = Nothing
        '-------------------------------------
       On Error GoTo 0
       Exit Sub
    Err_Cmd_StandardMode_Click:
       If MsgBox("【版本信息】:" & 版本 & vbCrLf & "【错误代码】:" & Err.Number & vbCrLf & "【错误描述】:" & Err.Description & vbCrLf & "【出错位置】: [Form1]→ [Cmd_StandardMode_Click]的 " & Erl & "" & vbCrLf & "是否继续?", vbYesNo + vbQuestion + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    

    6.通过借助VSFlexGrid控件(一个相当相当好用的数据展示控件)的SaveGrid方法导出,导出过程瞬间完成,即使电脑上不安装Excel应用程序也没有问题。

    代码如下:

        Dim SQL As String
        Dim FilePath As String
        On Error GoTo Err_Cmd_VSFlexGrid2Excel_Click
        '-------------------------------------
        FilePath = App.Path & "\" & Format(Now, "yyyy-MM-dd-hh_mm_ss") & "借助VSFlexGrid导出Excel.xls"
        ConnMDB
        If RS.State Then RS.Close
        SQL = "select * from student"
        RS.Open SQL, Cnn, adOpenForwardOnly, adLockReadOnly
        Set VSFlexGrid1.DataSource = RS
        '导出数据
        VSFlexGrid1.SaveGrid FilePath, flexFileExcel, flexXLSaveFixedCells Or flexXLSaveRaw
        MsgBox "导出OK!"
        Shell "explorer " & FilePath   '打开excel表格
        '-------------------------------------
       On Error GoTo 0
       Exit Sub
    Err_Cmd_VSFlexGrid2Excel_Click:
       If MsgBox("【版本信息】:" & 版本 & vbCrLf & "【错误代码】:" & Err.Number & vbCrLf & "【错误描述】:" & Err.Description & vbCrLf & "【出错位置】: [Form1]→ [Cmd_VSFlexGrid2Excel_Click]的 " & Erl & "" & vbCrLf & "是否继续?", vbYesNo + vbQuestion + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    
    展开全文
  • VB操作EXCEL表的常用方法

    万次阅读 多人点赞 2019-01-07 17:39:12
    VB是常用的应用软件开发工具之一...但由于VBEXCEL由于分别属于不同的应用系统,如何把它们有机地结合在一起,是一个值得我们研究的课题。 一、 VB读写EXCEL表: VB本身提自动化功能可以读写EXCEL表,其方法如下: ...
  • VB 代码读取 Excel 内容

    万次阅读 2017-05-25 11:16:20
    此处使用Open Recordset 的方式,将 Excel Worksheet 作为一个数据源直接读取 速度将是数理级的差别,几万笔记录的情况下,将由几十秒,甚至几分钟,加快至几稍钟 '导入Excel 文件内容 'Excel 格式为 Excel 2007 ...
  • vb读取excel中的数据

    2009-03-03 11:12:08
    VB or VBA 读取excel所有数据 取得excel文件所有内容
  • 该程序里面详细地说明了vb.net如何从数据库里面提取数据,之后将数据导出生成excel
  • vb快速读取excel文件 快速关闭所有Excel文件 (Quickly Close All Your Excel Files) First, I’ve got two quick announcements, and then there’s a handy Excel trick for you. Are you ready for Spreadsheet ...
  • 这是我个人运用Excel VBA在EXcel中实现的提取单元格中特定文字,并用”.“来标注此单元格是否存在这个字符的小程序。
  • 当遇到要将多个Excel下的数据归并时,特别是Excel数据量达到GB级别时,复制粘贴操作就显得很LOW,这种傻瓜操作要做几天几夜都没法处理完,外行人只能看Excel发叹.这时开发工具下的VB编辑器就起作用了.这里秀一波操作,...
  • 近日一直在研究Excel VBA,昨天看到了《处理外部数据和文件》这一章节,本来照猫画虎的抄代码可以一键过,没想到遇到了诸多问题,经过几个小时的搜索汇总,最终形成了以下几点经验(本机安装win7 office2016)。...
  • 这个宏的作用是:把当前文件夹下每一个excel文件的每一行(共8行)复制到总表的每一个sheet工作表中去,即把一个文件里的那1张表的8行复制转换成另一个文件的8张表里的8行,主要用于汇总工作
  • 提取Excel中的超链接

    2021-07-16 18:57:45
    以下图为例,先建立一个excel,在A列放置要转换的超链接,B列要为空,留着显示提取后的结果。 3.点击快捷键Alt+F11,打开Microsoft Visual Basic for Applications窗口,点击 “插入->模块” 4.在模块中输入如下...
  • VB读取excel数据

    千次阅读 2010-11-17 10:10:00
    在“工程”的“引用”中选择“microsoft excel 11.0”,"microsoft excel 11.0"看版本而定 Dim xlApp As New Excel.Application Dim xlBook As New Excel.Workbook Dim xlSheet As New Excel....
  • matlab导入excel代码近红外数据提取 用于Microsoft Excel VBA宏的近红外(NIR)数据提取工具。 NIR数据由德州仪器(TI)的DLP:registered:NIRscan:trade_mark:Nano评估模块通过扫描生成为.csv文件。 默认情况下,此...
  • 如何在Excel中使用VB宏连接SAP系统。 注意,Excel连接SAP的时候需要使用RFC library, 首先从Service Marketing Place下载RFC SDK. 路径:http://service.sap.com/swdc
  • 如何将VB中的数据导出excel,word中去

    热门讨论 2009-09-05 14:45:26
    本文详细讲叙了怎么把vb中的数据导入到excel,word中,看了包你受益不浅,呵呵!
  • Excel VBA 根据Sheet2中的表格数据处理Sheet1中的数据,包括:1,sheet1和sheet2指定数据的循环比较;2,符合条件的数据复制至sheet1中,并且用表格颜色进行标记
  • 我有一个excel报告,里面包含了名为“图表1”的曲线图,现在想用vb.net设计一个窗体,窗体包含: 1、一个按钮,点击即弹出“打开文件”窗口,选择excel报告(此部分已实现); 2、一个chart控件或者picturebox控件...
  • VBA操作网页读取数据自动填入EXCEL表中
  • 软件功能:筛选提取电子表格Excel中重复的或不重复的数据并汇总其频数,重复次数可以自定义范围,也可以将重复的数据只保留一个而重复的全部删除,功能实现多样化,是财务统计、数据管理行业人员的最得力帮手。...
  • 应广大使用朋友邀请,在此公布本人写的批量提取EXCEL文件数据源代码。整个项目开发环境:VS2008,VB语言书写。解压后,请在VS2008中使用打开项目上,找到解压后的项目文件MYEXCEL.SLN文件,打开它即可看到整个项目...
  • 本例使用到的Excel文件为:职员信息登记表.xlsx,如下图所示: 图21-10 职员信息登记表 窗体设计如下图所示(注意:为了演示方便,已经填充了数据): 图21-11 窗体设计 在本例中还需要掌握的知识: 1、...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 2,759
精华内容 1,103
关键字:

vb对excel数据进行提取