VBA 编程常见实例

精品文档 1欢迎下载 1 将 excel 汇总好的表 按字段拆分为多 sheet 的情况 如下图 代码如下 Sub cfs Dim GSArr As String 公司名称清单 Dim Rca As Integer A 列数据行数 Dim i As Integer Dim Sn As String Sn ActiveSheet Name Rca Columns A A End xlDown Row 按第 A 列数据拆分 且第一行无合并单元格 ReDim GSArr 1 To 1 GSArr 1 Cells 2 1 For i 3 To Rca If IsError Application Match Cells i 1 GSArr 0 Then ReDim Preserve GSArr 1 To UBound GSArr 1 GSArr UBound GSArr Cells i 1 End If Next 精品文档 2欢迎下载 If ActiveSheet AutoFilterMode False Then Rows 1 1 AutoFilter Else If ActiveSheet FilterMode True Then ActiveSheet ShowAllData End If For i 1 To UBound GSArr ActiveSheet Cells AutoFilter Field 1 Criteria1 GSArr i Sheets Add After Sheets Sheets Count ActiveSheet Name GSArr i Sheets Sn Cells Copy ActiveSheet Cells Sheets Sn Activate Next ActiveSheet Cells AutoFilter End Sub 2 将汇总的好的 EXCEL 表按字段拆分为多个工作薄 精品文档 3欢迎下载 代码如下 Sub CFGZB Dim myRange As Variant Dim myArray Dim titleRange As Range Dim title As String Dim columnNum As Integer myRange Application InputBox prompt 请选择标题行 Type 8 myArray WorksheetFunction Transpose myRange Set titleRange Application InputBox prompt 请选择拆分的表头 必须是第一 行 且为一个单元格 如 姓名 Type 8 title titleRange Value columnNum titleRange Column Application ScreenUpdating False Application DisplayAlerts False Dim iextended properties excel 8 0 data source ThisWorkbook FullName 2013 版连接字符 Sql select from 数据源 where title k i Dim Nowbook As Workbook Set Nowbook Workbooks Add With Nowbook With Sheets 1 Name k i For num 1 To UBound myArray Cells 1 num myArray num 1 Next num Range A2 CopyFromRecordset conn Execute Sql 精品文档 5欢迎下载 End With End With ThisWorkbook Activate Sheets 1 Cells Select Selection Copy Workbooks Nowbook Name Activate ActiveSheet Cells Select Selection PasteSpecial Paste xlPasteFormats Operation xlNone SkipBlanks False Transpose False Application CutCopyMode False Nowbook SaveAs ThisWorkbook Path k i Nowbook Close True Set Nowbook Nothing Next i conn Close Set conn Nothing Application DisplayAlerts True Application ScreenUpdating True End Sub 精品文档 6欢迎下载 3 将含有多 sheet 的一个工作表 按 sheet 名拆分为工作表 代码如下 Private Sub 分拆工作表 Dim sht As Worksheet Dim MyBook As Workbook Set MyBook ActiveWorkbook For Each sht In MyBook Sheets sht Copy ActiveWorkbook SaveAs Filename MyBook Path sht Name FileFormat xlNormal 将工作簿另存为 EXCEL 默认格式 精品文档 7欢迎下载 ActiveWorkbook Close Next MsgBox 文件已经被分拆完毕 End Sub 4 将多个工作薄合并为一个多 sheet 的工作薄 精品文档 8欢迎下载 代码如下 Sub Books2Sheets 定义对话框变量 Dim fd As FileDialog Set fd Application FileDialog msoFileDialogFilePicker 新建一个工作簿 Dim newwb As Workbook Set newwb Workbooks Add With fd If Show 1 Then 定义单个文件变量 Dim vrtSelectedItem As Variant 定义循环量 Dim i As Integer i 1 精品文档 9欢迎下载 开始文件检索 For Each vrtSelectedItem In SelectedItems 打开被合并工作簿 Dim tempwb As Workbook Set tempwb Workbooks Open vrtSelectedItem 复制工作表 tempwb Worksheets 1 Copy Before newwb Worksheets i 把新工作簿的工作表名字改成被复制工作簿文件名 这儿应用于 xls 文件 即 Excel97 2003 的文件 如果是 Excel2007 需要改成 xlsx newwb Worksheets i Name VBA Replace tempwb Name xls 关闭被合并工作簿 tempwb Close SaveChanges False i i 1 Next vrtSelectedItem End If End With Set fd Nothing End Sub 5 将含有多个 sheet 的工作表内容信息汇总至一个 sheet 中 精品文档 10欢迎下载 Sub Combine Dim J As Integer On Error Resume Next Sheets 1 Select Worksheets Add Sheets 1 Name Combined Sheets 2 Activate Range A1 EntireRow Select 精品文档 11欢迎下载 Selection Copy Destination Sheets 1 Range A1 For J 2 To Sheets Count Sheets J Activate Range A1 Select Selection CurrentRegion Select Selection Offset 1 0 Resize Se