Excel VBA 批量处理表格

' ************************************************************************
' Routine Name : 
' Written By : Eddy
' Date Writen : 2019-08-15 20:01:07
' Inputs : N/A
' Outputs : N/A
' Description :
' :
' :
' ************************************************************************
Sub split()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sht As Worksheet, wkb As Workbook, target_sht As Worksheet
    Dim init_row As Integer, total_row As Integer, init_col As Integer, i As Integer
    Dim myDic As New Dictionary
    Dim arr As Variant
    Dim rsp

        rsp = MsgBox("执行拆分程序，请确认已经选择了需要拆分的列名！", vbOKCancel)

        If rsp = vbCancel Then
            Exit Sub
        End If

        Set sht = ActiveSheet
        Set wkb = ActiveWorkbook
        init_row = Selection.Row
        init_col = Selection.Column
        total_row = sht.Cells(Rows.Count, init_col).End(xlUp).Row
        Set myDic = CreateObject("scripting.dictionary")
        
        For i = init_row + 1 To total_row
            If Not myDic.Exists(sht.Cells(i, init_col).Value) Then
                myDic(sht.Cells(i, init_col).Value) = "init"
                Call create_sht(sht.Cells(i, init_col).Value, wkb, sht, init_row)
                Set target_sht = wkb.Sheets(sht.Cells(i, init_col).Value)
                sht.Rows(i).Copy target_sht.Rows(init_row + 1)
            Else
                Set target_sht = wkb.Sheets(sht.Cells(i, init_col).Value)
                target_row = target_sht.Cells(Rows.Count, init_col).End(xlUp).Row
                sht.Rows(i).Copy target_sht.Rows(target_row + 1)
            End If
        Next i
        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub create_sht(shtName As String, wkBook As Workbook, wkSht As Worksheet, init_row As Integer)
    Dim sh As Worksheet
    Dim new_sh As Worksheet

    For Each sh In wkBook.Sheets
          If sh.Name = shtName Then sh.Delete
    Next

    Set new_sh = wkBook.Sheets.Add(, after:=wkSht)
    new_sh.Name = shtName
    wkSht.Rows("1:" & init_row).Copy new_sh.[a1]
End Sub

Sub 遍历所有文件()
    Dim MyName, Dic, i, x, t, f, TT, MyFileName
    Dim Ipath As String
    Dim arr(), n As Integer
    x = 2
    t = Time
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then Ipath = .SelectedItems(1) Else Exit Sub
    End With
    If Right(Ipath, 1) <> "\" Then Ipath = Ipath & "\"
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Dic.Add (Ipath), ""
    i = 0
    Do While i < Dic.Count
        Ke = Dic.Keys   '开始遍历字典
        MyName = Dir(Ke(i), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(i) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        i = i + 1
    Loop

    For Each Ke In Dic.Keys
        MyFileName = Dir(Ke & "*.*")
        Do While MyFileName <> ""
          '往目录添加文件路径
             n = n + 1
             ReDim Preserve arr(1 To 5, 1 To n)
             arr(1, n) = MyFileName
             arr(2, n) = Round(GetFileSize(Ke & MyFileName) / 1024, 1) & "KB"
             arr(3, n) = FileDateTime(Ke & MyFileName)
             arr(4, n) = FileType(MyFileName)
             arr(5, n) = Ke & MyFileName
             MyFileName = Dir
        Loop
    Next
    '清除文件清单内容
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "文件清单" Then
            Sheets("文件清单").Cells.Delete
            f = True
            Exit For
        Else
            f = False
        End If
    Next
    '命名清单名称
    If Not f Then
        Sheets.Add.Name = "文件清单"
    End If
    '添加显示信息
    With Sheets("文件清单")
        .Cells(1, 1) = "目录名"
        .Cells(1, 2) = "文件大小"
        .Cells(1, 3) = "创建日期"
        .Cells(1, 4) = "文件类型"
        .Cells(1, 5) = "文件路径"
        .Range("A1:E1").Font.Bold = True
        .[A2].Resize(n, 5) = WorksheetFunction.Transpose(arr)
        Do While Not IsEmpty(.Cells(x, 1))
          .Hyperlinks.Add Anchor:=.Cells(x, 1), Address:=.Cells(x, 5)
           x = x + 1
        Loop
    End With
    TT = Time - t
    MsgBox Minute(TT) & "分" & Second(TT) & "秒"
End Sub

Function GetFileSize(filespec)
    Dim fs, f
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(filespec)
    GetFileSize = f.Size
End Function

Function FileType(FileLoad)
    Dim i As Integer, n As Integer
    For i = 1 To Len(FileLoad)
        If Mid(FileLoad, i, 1) = "." Then n = i
    Next
    If n = 0 Then
    FileType = ""
    Else
    FileType = Right(FileLoad, Len(FileLoad) - n)
    End If
End Function

Sub Test()
    Dim regx, S$, Strnew$
    S = "正则表达式其实很简单     "
    Set regx = CreateObject("vbscript.regexp")
    regx.Pattern = "\s+$"
    regx.Global = True
    Strnew = regx.Replace(S, "")
    MsgBox Strnew
End Sub

Function vbalookup(lookupRange As Range, refRange As Range, dataCol As Long) As Variant
Dim dict As New Scripting.Dictionary
Dim myRow As Range
' 新建字典
On Error Resume Next
For Each myRow In refRange.Columns(1).Cells
' 遍历添加
    dict.Add myRow.Value, myRow.Offset(0, dataCol - 1).Value
Next myRow
'输出结果
vbalookup = dict(lookupRange.Value)
End Function

Function vbalookup2(lookupRangepart As Range, refRange As Range, dataCol As Long) As Variant
  Dim dict As New Scripting.Dictionary
  Dim myRow As Range
  Dim I As Long, J As Long
  Dim vResults() As Variant
  Dim LastRow As Long
  Dim Columnselect As String
  Dim lookupRangepartString As String
  Dim lookupRangefull As String
  Dim lookupRange As Range
  Dim FirstPart As String
          
' Finds last entry on any column
  LastRow = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
           
' Generates variable for the targeted Column e.g. A
  Columnselect = Left(lookupRangepart, 1)
  
' Build complete range to lookup
    strColumn = Replace(lookupRangepart.Address, "$", "")
    lookupRangefull = strColumn & ":" & Left(strColumn, Len(strColumn) - 1)
    If IsNumeric(Right(lookupRangefull, 1)) Then lookupRangefull = Left(lookupRangefull, Len(lookupRangefull) - 1)
    lookupRangefull = lookupRangefull & LastRow
  
  Set lookupRange = Range(lookupRangefull)
  
  ' 1. Build a dictionnary
  On Error Resume Next
  For Each myRow In refRange.Columns(1).Cells
    ' Append A : B to dictionnary
    dict.Add UCase(myRow.Value), myRow.Offset(0, dataCol - 1).Value
  Next myRow

  ' 2. Use it over all lookup data
  ReDim vResults(1 To lookupRange.Rows.Count, 1 To lookupRange.Columns.Count) As Variant
  For I = 1 To lookupRange.Rows.Count
    For J = 1 To lookupRange.Columns.Count
      If dict.Exists(UCase(lookupRange.Cells(I, J).Value)) Then
        vResults(I, J) = dict(UCase(lookupRange.Cells(I, J).Value))
      End If
    Next J
  Next I

  vbalookup = vResults
  
  End Function