幾個vba小程序

1.數據彙總——彙總文件夾下所有excel文件的某列，組成新的一列。

Sub 彙總()
    Dim Fso, Fld, Fl
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fld = Fso.getfolder(ThisWorkbook.Path & "\data\")
    If Fld.Files.Count > 0 Then
        Application.ScreenUpdating = False
        For Each Fl In Fld.Files
            xh = ThisWorkbook.Worksheets(1).[A65536].End(xlUp).Row + 1
            Workbooks.Open (Fl)
            h = ActiveWorkbook.Worksheets(1).[A65536].End(xlUp).Row
            ActiveWorkbook.Worksheets(1).[a1].Resize(h, 1).Copy ThisWorkbook.Worksheets(1).Cells(xh, 1)
            ActiveWorkbook.Close
        Next
        Application.ScreenUpdating = True
        MsgBox "數據彙總完成"
    Else
        MsgBox "沒有找到任何工作簿文件"
    End If
End Sub

2.刪除單元格中包含某些字符的行

Sub 刪除行()
For i = Sheet1.[A65536].End(xlUp).Row To 2 Step -1
    If Sheet1.Cells(i, "A").Value Like "*表1*" Then Rows(i).Delete
    If Sheet1.Cells(i, "A").Value Like "單位：人、戶" Then Rows(i).Delete
    If Sheet1.Cells(i, "A").Value Like "地區" Then Rows(i).Delete    
Next i
End Sub

3.另存爲文本

把excel中某列的數據保存爲文本，每個單元格爲一行

Sub 另存爲文本()
    Application.ScreenUpdating = False
    Dim nRow As Long, nColumn%, cBT$, cTxt$
    Dim str  As String
    str = ThisWorkbook.Path
    str = Mid(str, 16, 4)
    nRow = Sheets(1).Range("A65536").End(xlUp).Row             'Range("A65536") A列所有行，注意這裏是字母和數字的結合
    Open ThisWorkbook.Path & "\" & str & ".txt" For Output As #1
    
For i = 1 To nRow
    cTxt = Sheets(1).Cells(i, "A") & Chr(13)
    Print #1, cTxt
Next
    Close #1
    'Next
    Application.ScreenUpdating = True
    'MsgBox "ok"
    MsgBox "另存文本文件，" & Chr(10) & Chr(10) & "已經完成！" & Chr(10)
End Sub

4.vlookup函數。在當前文件夾 E:\N2021030132\12\ 下，使用vlookup函數查詢所有excel文件的L列，講結果寫入A列，查詢的目標區域爲當前文件夾下12.xlsx的E列和F列。

Sub 匹配地名()
Dim str  As String
Dim wb As Workbook
Dim nRow As Integer
Dim o As Range
Dim r As Range
Dim Fso, Fld, Fl

str = ThisWorkbook.Path
str = Mid(str, 16, 2)

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fld = Fso.getfolder(ThisWorkbook.Path & "\data\")
    Set wb = GetObject(ThisWorkbook.Path & "\" & str & ".xlsx")    '12文件，文件名和目錄名相同，兩位數字
       With wb
        nRow = wb.Worksheets(1).[E65536].End(xlUp).Row
        Set o = wb.Sheets(1).Range("E" & 1 & ":" & "F" & nRow)
       End With
    Application.DisplayAlerts = False     '不顯示保存文件對話框
    If Fld.Files.Count > 0 Then
        Application.ScreenUpdating = False
        For Each Fl In Fld.Files
            Workbooks.Open (Fl)
            ActiveWorkbook.Sheets(1).Columns("L:L").ColumnWidth = 13.3  '設置列寬
            h = ActiveWorkbook.Worksheets(1).[A65536].End(xlUp).Row
            For i = 1 To h
               ActiveWorkbook.Sheets(1).Cells(i, "A").Value = Application.WorksheetFunction _
                    .VLookup(ActiveWorkbook.Worksheets(1).Range("L" & i), o, 2, 0)
            Next
            ActiveWorkbook.Close True
        Next
        Application.ScreenUpdating = True
        MsgBox "數據完成"
    Else
        MsgBox "沒有找到任何工作簿文件"
    End If
    Application.DisplayAlerts = True  '顯示保存文件對話框
    wb.Close False
    Set wb = Nothing
End Sub

現學現賣，不對的地方請大家指出來。