vba获取当前access路径 vba获取当前行

所以这里记录几个之前工作中高频使用的小小小脚本。

下面提到的工作簿，即单个的 .xlsx 或 .xls 文件，工作表就是文件里的 sheet 。

1、自定义函数

自定义一个 Countcolor()

无情，知乎的代码块提供了几十种语言，就是没有VB……

Function Countcolor(arr As Range, c As Range)
    Dim rng As Range
    For Each rng In arr
        If rng.Interior.Color = c.Interior.Color Then
            Countcolor = Countcolor + 1
        End If
    Next rng
End Function

函数说明：

比如在单元格输入 =countcolor(B2:F16,B8)，会返回区域 (B2:F16) 内与 B8 单元格颜色相同的单元格数。

2、合并工作簿

依次打开某个文件夹下的 EXCEl 工作簿，将每一个工作簿下所有 Sheets 复制到当前的工作簿中。

Sub BooksMerge()
    Dim FileOpen
    Dim X As Integer
    Application.ScreenUpdating = False

    FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft_Excel文件(*.xls*),*.xls*", MultiSelect:=True, Title:="合并工作薄")
    X = 1
    While X <= UBound(FileOpen)      ' UBound():返回数组最大下标
        Workbooks.Open Filename:=FileOpen(X)
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    X = X + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
errhadler:
    MsgBox Err.Description
End Sub

3、合并工作表

新建一个空白的 sheet，把工作簿下所有 Sheet 里的数据按顺序逐行复制到这个新建的空白表格中。

比如2019年上证指数的行情数据，按季度分在了4张工作表里，这里希望把它们合在一个表格里：

复制以下代码：

Sub SheetsMerge()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sheets_pre As Integer, sheets_aft As Integer

    sheets_pre = Sheets.Count

    '删除空白的的工作表，如无必要，这步可省略
    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Cells.Find(What:="1") Is Nothing And sht.Name <> "0" Then
            sht.Delete
        End If
    Next

    '在第一位新建一个空白汇总表，表名"2019年汇总"
    ThisWorkbook.Sheets.Add Before:=Worksheets(1)
    ActiveSheet.Name = "2019年汇总"
    
    '把第一张表包括表头（第一行）复制到汇总表
    For i = 1 To Sheets(2).Range("A65536").End(xlUp).Row
        Sheets(2).Rows(i).Copy Rows(i)
    Next
    
    '把后面的表去掉表头后复制到汇总表，
    For j = 3 To Sheets.Count
        If Sheets(j).Name <> ActiveSheet.Name Then
            Y = Sheets(j).Range("A65536").End(xlUp).Row
            X = Range("A65536").End(xlUp).Row
            For i = 1 To Y
                Sheets(j).Rows(i + 1).Copy Rows(X + i)
            Next
        End If
    Next
    
    Range("B1").Select
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    sheets_aft = Sheets.Count - 1
    
    '完成后弹出窗口提示
    MsgBox "当前工作簿下的全部工作表已经合并完毕！" & vbCrLf & _
           "共有" & sheets_pre & "张表," & "合并了" & sheets_aft & "张。"
End Sub

保存后，执行「宏」，效果应该是这样的：

4、分组后拆分到工作表

把一个表格里的数据，按某一列分组，每一组的数据复制到一张新的工作表中。

比如：继续前面的2019年上证指数行情数据，在第一列新增「月份」字段，现在希望每个月的行情数据单独放在一张 Sheet

复制以下代码：

Sub Sheetsplit()

    Dim arr, rngHead As Range, rngTotal As Range, d As Object, _
    k, t, r&, i&, lr&, lc%, sh As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    arr = Range("a1").CurrentRegion
    lr = UBound(arr)
    lc = UBound(arr, 2)
    
    Set rngHead = Rows(1)
    Set rngTotal = Rows(lr)
    Set d = CreateObject("scripting.dictionary")
    
    For i = 2 To lr - 1
        If Not d.Exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Cells(i, 1).Resize(, lc)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(, lc))
        End If
    Next
    
    k = d.Keys
    t = d.Items
    
    With Sheets
        For i = 0 To d.Count - 1
            With .Add(After:=.Item(.Count))
                .Name = k(i)
                rngHead.Copy .[a1]
                .Cells(1, 1).Resize(, lc).Columns.AutoFit
                t(i).Copy .[a2]
            End With
        Next
    End With
    
    Sheets(1).Activate
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

保存后，执行「宏」，效果应该是这样的：

5、工作表保存为工作簿

把 EXCEL 文件里每一张 Sheet

比如：继续使用前面的行情数据，把每个月的行情保存为单独的一个 EXCEL

复制以下代码：

Sub Booksplit()

   Application.ScreenUpdating = False
   
   Dim folder As String
   folder = ThisWorkbook.Path & "" & "Index"
   
   If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
   
   Dim sht As Worksheet
   For Each sht In Worksheets
       If sht.Name <> "" Then
           sht.Copy
           ActiveWorkbook.SaveAs folder & "" & sht.Name
           ActiveWorkbook.Close
       End If
   Next
   
   Application.ScreenUpdating = True
   
End Sub

保存后，执行「宏」，我们在同样的文件路径下会发现一个新的文件夹「Index」：