备忘:合并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里用?

百度啊!百度呀!百度哇!你™不会百度吗?

分享到: