备忘：合并Excel文件和工作表的VBA（以及别的）

都是谷歌到的VBA，似乎好像暂时找不到出处了，以后找到再补……有些时候处理Excel表格没这几个宏实在是憋屈，又不能随身带着，放这儿备忘。

合并同一个文件夹的多个Excel文件

作用：把位于同一个文件夹（不含子文件夹）内的所有Excel文件依次打开，把所有的工作表复制到同一个工作簿中，比方说你有一个月每天的表格，想合并成一个月的整表，一个一个单独拷贝太墨迹了。

来源：ExtendOffice

Sub CombineWorkbooks()
     
    Dim Path            As String
    Dim FileName        As String
    Dim Wkb             As Workbook
    Dim WS              As Worksheet
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Path = "X:\PATH\TO\EXCEL\FILES" '包含表格的文件夹
    FileName = Dir(Path & "\*.xls", vbNormal)
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each WS In Wkb.Worksheets
            WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next WS
        Wkb.Close False
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
     
End Sub

把一个工作簿中的所有工作表合并成一个

作用：把同一个工作簿中所有的工作表合并成一个总表，比如你有一个月的数据，里面有每天的一共30个工作表，想合并成整月的大表，就用这个。运行之后的结果会出现在一个单独的“RDBMergeSheet”工作表中，接下来就随意了。

注意：Excel 2003格式（.xls）只支持65536行，容易爆行数，内容比较多的时候先转成.xlsx。

来源：MSDN

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function



Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.UsedRange

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            'DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

把整个工作表的合并单元格取消合并

作用：把当前工作表所有的合并单元格取消合并，并且把之前的内容填充到拆分后的所有单元格中。比方说你需要来个数据透视表，但是给你的原始数据前面是合并起来的，与其手工取消合并然后Ctrl+回车一个个填充，不如直接一个宏。

Sub 取消合并单元格并填充()

Dim cell As Range, joinedCells As Range

For Each cell In ThisWorkbook.ActiveSheet.UsedRange
    If cell.MergeCells Then
        Set joinedCells = cell.MergeArea
        cell.MergeCells = False
        joinedCells.Value = cell.Value
    End If
Next

End Sub

生成VCF联系人文件

作用：单位给了你一份Excel格式的通讯录，打算导入手机的时候，可以先按照姓、名、手机号三列做成个新表，然后用这个生成VCF，之后基本上是个手机都能导入了。注意不同的手机对于姓名的排列顺序可能不一样，可以先做一个测试，没问题之后再生成完整的。

Sub Create_VCF()
    'Open a File in Specific Path in Output or Append mode
    Dim FileNum As Integer
    Dim iRow As Double
    iRow = 2
    FileNum = FreeFile
    OutFilePath = "C:\OutputVCF.VCF" '生成的VCF文件路径
    Open OutFilePath For Output As FileNum
    'Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> ""
        FName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1))
        LName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2))
        PhNum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3))
        Print #FileNum, "BEGIN:VCARD"
        Print #FileNum, "VERSION:3.0"
        Print #FileNum, "N:" & FName & ";" & LName & ";;;"
        Print #FileNum, "FN:" & FName & " " & LName
        Print #FileNum, "TEL;TYPE=CELL;TYPE=PREF:" & PhNum
        Print #FileNum, "END:VCARD"
        iRow = iRow + 1
    Wend
    'Close the File
    Close #FileNum
    MsgBox "Contacts Converted to Saved To: " & OutFilePath
End Sub

这些代码怎么在Excel里用？

百度啊！百度呀！百度哇！你™不会百度吗？