當前位置:成語大全網 - 新華字典 - 如何通過VBA宏實現壹個表裏的內容按內容不同復制粘貼成多個表格?!如下圖

如何通過VBA宏實現壹個表裏的內容按內容不同復制粘貼成多個表格?!如下圖

答:如果已經創建好了sheet2、sheet3、sheet4這3張表,可以下面代碼:

Sub?demo1()

Dim?d?As?Object

Dim?i?As?Long

Dim?Rng?As?Range

Set?Rng?=?Range("A1").CurrentRegion

Set?d?=?CreateObject("scripting.dictionary")

For?i?=?2?To?Cells(Rows.Count,?"C").End(xlUp).Row

d(Cells(i,?"C").Value)?=?""

Next

Application.ScreenUpdating?=?False

For?i?=?0?To?d.Count?-?1

With?Rng

.AutoFilter?3,?Filter(d.keys,?"")(i)

.SpecialCells(xlCellTypeVisible).Copy

Select?Case?Filter(d.keys,?"")(i)

Case?"壹組"

Sheets("Sheet2").Paste?Sheets("Sheet2").Range("A1")

Case?"二組"

Sheets("Sheet3").Paste?Sheets("Sheet3").Range("A1")

Case?"三組"

Sheets("Sheet4").Paste?Sheets("Sheet4").Range("A1")

End?Select

End?With

Next

Rng.AutoFilter

Application.ScreenUpdating?=?True

End?Sub

如是直接分割到3張新工作中去,可以下面代碼

Sub?demo2()

Dim?d?As?Object

Dim?i?As?Long

Dim?Rng?As?Range?

Set?Rng?=?Range("A1").CurrentRegion

Set?d?=?CreateObject("scripting.dictionary")

For?i?=?2?To?Cells(Rows.Count,?"C").End(xlUp).Row

d(Cells(i,?"C").Value)?=?""

Next

Application.ScreenUpdating?=?False

For?i?=?0?To?d.Count?-?1

With?Rng

.AutoFilter?3,?Filter(d.keys,?"")(i)

.SpecialCells(xlCellTypeVisible).Copy

With?Sheets.Add

.Paste?.Range("A1")

End?With

End?With

Next

Rng.AutoFilter

Application.ScreenUpdating?=?True

End?Sub