VBA—按某个工作表某列数据拆分成多表格
Sub cfsj()
Dim i As Integer
Dim j As Integer
Dim hs, hss As Integer
Dim sht As Worksheet
Dim sht1 As Worksheet
Dim wk As Workbook
yjls = Excel.Application.InputBox(请输入拆分表格所依据的列, 请输入, 输入数字, , , , , 1)
Set sht1 = Excel.ActiveSheet
Set wk = Excel.ActiveWorkbook
hs = sht1.Range("a65536").End(xlUp).Row
For i = 2 To hs
k = 0
For Each sht In Sheets
If sht.Name = sht1.Cells(i, yjls) Then
k = k + 1
End If
Next
If k = 0 Then
Worksheets.Add after:=wk.Sheets(wk.Sheets.Count)
wk.Sheets(wk.Sheets.Count).Name = sht1.Cells(i, yjls)
End If
Next
For j = 1 To wk.Sheets.Count
hss = wk.Sheets(j).Range("a65536").End(xlUp).Row
If hss = 1 Then
sht1.Range("a1:z" & hs).AutoFilter Field:=yjls, Criteria1:=wk.Sheets(j).Name
sht1.Range("a1:z" & hs).Copy wk.Sheets(j).Range("a" & hss)
sht1.Range("a1:z" & hs).AutoFilter
Else:
sht1.Range("a1:z" & hs).AutoFilter Field:=yjls, Criteria1:=wk.Sheets(j).Name
sht1.Range("a2:z" & hs).Copy wk.Sheets(j).Range("a" & hss + 1)
sht1.Range("a1:z" & hs).AutoFilter
End If
Next
End Sub