VBA 编程常见实例

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列数据拆分，且第一行无合并单元格

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

If ActiveSheet.AutoFilterMode = False Then Rows(\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表按字段拆分为多个工作薄

代码如下： Sub CFGZB()

Dim myRange As Variant Dim myArray

Dim titleRange As Range Dim title As String

Dim columnNum As Integer

myRange = Application.InputBox(prompt:=\请选择标题行：\ myArray = WorksheetFunction.Transpose(myRange)

Set titleRange = Application.InputBox(prompt:=\请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”\ title = titleRange.Value

columnNum = titleRange.Column Application.ScreenUpdating = False Application.DisplayAlerts = False Dim i&, Myr&, Arr, num& Dim d, k

For i = Sheets.Count To 1 Step -1

If Sheets(i).Name <> \数据源\ ‘待拆分的表sheet名为：数据源 Sheets(i).Delete End If Next i

Set d = CreateObject(\

Myr = Worksheets(\数据源\

Arr = Worksheets(\数据源\ For i = 1 To UBound(Arr) d(Arr(i, 1)) = \ Next

k = d.keys

For i = 0 To UBound(k)

Set conn = CreateObject(\

conn.Open \properties=excel 8.0;data source=\‘2013版连接字符

Sql = \数据源$] where \ 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(\ 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 & \ Nowbook.Close True Set Nowbook = Nothing Next i

conn.Close

Set conn = Nothing

Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

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 FileFormat:=xlNormal '将工作簿另存为EXCEL默认格式 ActiveWorkbook.Close Next

MsgBox \文件已经被分拆完毕!\ End Sub

& \& sht.Name,

4,、将多个工作薄合并为一个多sheet的工作薄

代码如下：

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

'开始文件检索

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,\ '关闭被合并工作簿 tempwb.Close SaveChanges:=False i=i+1 Next vrtSelectedItem End If End With Set fd=Nothing End Sub

5、 将含有多个sheet的工作表内容信息汇总至一个sheet中

Combine()

Dim J As Integer

On Error Resume Next Sheets(1).Select Worksheets.Add

Sheets(1).Name = \Sheets(2).Activate

Range(\

Selection.Copy Destination:=Sheets(1).Range(\For J = 2 To Sheets.Count Sheets(J).Activate Range(\

Selection.CurrentRegion.Select

Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

Selection.Copy Destination:=Sheets(1).Range(\Next End Sub

Sub