|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
'算了,新年刚开始还是给你修改一下吧(自己修改数据),,,
Option Explicit
Sub test()
Dim arr, filename, i, j, m, sum, n
filename = ThisWorkbook.Path & "\数据源.xlsx"
If Len(Dir(filename)) = 0 Then MsgBox filename: Exit Sub
With Workbooks.Open(filename)
With .ActiveSheet
For i = 3 To 33
If .Cells(1, i) <> "Sun" Then
.Cells(3, i) = 67: .Cells(7, i) = 4 '数据自己修改
.Cells(5, i) = 67: .Cells(9, i) = 4 '数据自己修改
End If
Next
arr = .UsedRange
End With
.Close True
End With
ReDim brr(1 To UBound(arr, 2) * 2, 1 To UBound(arr, 1) - 2 + 1)
ReDim sum(2 To UBound(brr, 2))
For j = 3 To UBound(arr, 2) - 1
m = m + 1: brr(m, 1) = arr(2, j)
For i = 3 To UBound(arr, 1)
brr(m, i - 1) = arr(i, j)
sum(i - 1) = sum(i - 1) + arr(i, j)
Next
If arr(1, j) = "Sat" Then
n = n + 1: m = m + 1: brr(m, 1) = "Week - " & n
For i = 2 To UBound(brr, 2): brr(m, i) = sum(i): Next
ReDim sum(2 To UBound(brr, 2))
End If
Next
With [a5]
.Resize(Rows.Count - 4, UBound(brr, 2)).ClearContents
.Resize(m, UBound(brr, 2)) = brr
End With
End Sub |
|