VBA 编程常见实例.docVIP

VBA编程常见实例

VBA编程常见实例

VBA编程常见实例

将excel汇总好的表，按字段拆分为多sheet的情况：如下图：

代码如下：Subcfs()

DimRcaAsIntegerA列数据行数

DimiAsInteger

DimSnAsString

Sn=ActiveSheet.Name

Rca=Columns(A:A).End(xlDown).Row‘按第A列数据拆分，且第一行无合并单元格tz6Wj。

ReDimGSArr(1To1)

GSArr(1)=Cells(2,1)

Fori=3ToRca

IfIsError(Application.Match(Cells(i,1),GSArr,0))ThenV6Ezd。

ReDimPreserveGSArr(1ToUBound(GSArr)+1)

GSArr(UBound(GSArr))=Cells(i,1)

EndIf

Next

IfActiveSheet.AutoFilterMode=FalseThen

Rows(1:1).AutoFilter

Else

IfActiveSheet.FilterMode=TrueThenActiveSheet.ShowAllDatakNXDb。

EndIf

Fori=1ToUBound(GSArr)

ActiveSheet.Cells.AutoFilterField:=1,Criteria1:=GSArr(i)NoviQ。

Sheets.AddAfter:=Sheets(Sheets.Count)

ActiveSheet.Name=GSArr(i)

Sheets(Sn).Cells.CopyActiveSheet.Cells

Sheets(Sn).Activate

Next

ActiveSheet.Cells.AutoFilter

EndSub

将汇总的好的EXCEL表按字段拆分为多个工作薄

代码如下：

SubCFGZB()

DimmyRangeAsVariant

DimmyArray

DimtitleRangeAsRange

DimtitleAsString

DimcolumnNumAsInteger

myRange=Application.InputBox(prompt:=请选择标题行：,Type:=8)ywCBP。

myArray=WorksheetFunction.Transpose(myRange)

SettitleRange=Application.InputBox(prompt:=请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”,Type:=8)OXkGp。

title=titleRange.Value

columnNum=titleRange.Column

Application.ScreenUpdating=False

Application.DisplayAlerts=False

Dimi,Myr,Arr,num

Dimd,k

Fori=Sheets.CountTo1Step-1

IfSheets(i).Name数据源Then‘待拆分的表sheet名为：数据源eXYo3。

Sheets(i).Delete

EndIf

Nexti

Setd=CreateObject(Scripting.Dictionary)

Myr=Worksheets(数据源).UsedRange.Rows.Count

Arr=Worksheets(数据源).Range(Cells(2,columnNum),Cells(Myr,columnNum))LPJFS。

Fori=1ToUBound(Arr)

d(Arr(i,1))=

Next

k=d.keys

Fori=0ToUBound(k)

Setconn=CreateObject(adodb.connection)

conn.Openprovider=microsoft.ace.oledb.12.0;exten