|
写了一个挺啰嗦的
Sub 拆分()
Dim wd As Workbook
r = [a65536].End(xlUp).Row
arr = Range("a1:c" & r)
ReDim brr(1 To 50, 1 To 3)
ReDim crr(1 To 50, 1 To 3)
ReDim drr(1 To 50, 1 To 3)
b = 1: c = 1: d = 1
For i = 2 To UBound(arr)
m = Format(arr(i, 1), "m")
Select Case m
Case 1
b = b + 1
For j = 1 To UBound(arr, 2)
brr(1, j) = arr(1, j)
brr(b, j) = arr(i, j)
Next j
Case 2
c = c + 1
For j = 1 To UBound(arr, 2)
crr(1, j) = arr(1, j)
crr(c, j) = arr(i, j)
Next j
Case 3
d = d + 1
For j = 1 To UBound(arr, 2)
drr(1, j) = arr(1, j)
drr(d, j) = arr(i, j)
Next j
End Select
Next i
Set wd = Workbooks.Add
wd.Sheets(1).Range("a1").Resize(b, 3) = brr
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "1月" & ".xlsx"
wd.Close False
Set wd = Workbooks.Add
wd.Sheets(1).Range("a1").Resize(c, 3) = crr
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "2月" & ".xlsx"
wd.Close False
Set wd = Workbooks.Add
wd.Sheets(1).Range("a1").Resize(d, 3) = drr
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "3月" & ".xlsx"
wd.Close False
End Sub
|
评分
-
1
查看全部评分
-
|