几个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

现学现卖，不对的地方请大家指出来。