excel,access常用公式函数VBA代码汇总文章

批量将CSV导入access

alt+f11 打开access的vbe环境

Sub test()
   
    Dim SQL As String
    Dim MyPath As String
    Dim MyPathDb As String
    Dim MyFile As String
   MyPath = "D:	emp*.CSV"
   MyPathDb = "D:	emp"
  
  
    MyFile = Dir(MyPath)
    Do
    SQL = "insert into 110 select * from [Text;DATABASE=" & MyPathDb & "].[" & MyFile & "]"
    DoCmd.RunSQL SQL
    'Debug.Print MyFile
    MyFile = Dir
      
    Loop Until MyFile = ""
   
     
 DoCmd.SetWarnings True
    
End Sub

　　直接运行此函数即可

1.根据日期返回星期：=TEXT(A2,"aaaa") A2中为日期

2.提取文本超链接放到后一列,以下代码的作用就是把文本下的链接提取，并放在后面1列。

　　

Sub 提取链接()

    Dim HL AsHyperlink

    For Each HL InActiveSheet.Hyperlinks

       HL.Range.Offset(0, 1).Value = HL.Address‘就是说把链接放在非单独链接的后面一列。

    Next

End Sub

　　

3.检测单元格变动（变动后着色）

Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox ("changed")
Target.Interior.ColorIndex = 3
Target.Font.ColorIndexf = 4
End Sub

　　

4.操作其它excel的sheet

Private Sub CommandButton1_Click()
  Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long
    Dim Num As Long
    Dim BOX As String
    flag = 0
     
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    'MsgBox MyPath
    MyName = Dir(MyPath & "" & "*.xls")
   ' MsgBox MyName
    AWbName = ActiveWorkbook.Name
    Num = 0
  
     
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "" & MyName)
            Num = Num + 1
            'MsgBox "正在处理第" & Num & "个工作表，名字是：" & Wb.Name
                    'If Wb.Sheets(3).Name = "签约" Then

                        With Workbooks(1).Worksheets(1)
                       ' MsgBox Workbooks(1).Worksheets(1).Name
    'wb.sheets(“xxx”).usedrange.copy 报错 
                           Wb.Sheets("签约").Range("a1:L65535").Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
                           .UsedRange.Rows.AutoFit
                           .UsedRange.Columns.AutoFit
                        End With
                   ' End If
                 flag = 1
                WbN = WbN & Chr(13) & Wb.Name
                Wb.Close SaveChanges:=0
           ' End With
        End If
        MyName = Dir
    Loop
        Range("A1").Select
         
         
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub