宏观数据后的第2部分
启动已运行。
| A | B | C | D | E | F | G | H | I |
1 |Year |Week |Amounts|--> | | | | | |
2 | 2002| 1| 0| 0| 0| 0| 0| | |
3 | 2002| 2| 10| 20| 30| 40| | | |
4 | 2002| 3| 11| 21| 31| 41| 51| | |
5 | 2002| 4| 0| 0| 0| 0| 0| | |
6 | 2002| 5| 0| 0| 0| 0| 0| | |
7 | 2002| 6| 0| 0| 0| 0| 0| | |
8 | 2002| 7| 0| 0| 0| 0| 0| | |
9 | 2002| 8| 0| 0| 0| 0| 0| | |
10 | 2002| 9| 0| 0| 0| 0| 0| | |
11 | 2002| 10| 0| 0| 0| 0| 0| | |
12 | 2002| 11| 0| 0| 0| 0| 0| | |
13 | 2002| 12| 0| 0| 0| 0| 0| | |
14 | 2002| 13| 0| 0| 0| 0| 0| | |
15 | 2002| 14| 0| 0| 0| 0| 0| | |
16 | 2002| 15| 24| 34| 44| 54| 64| | |
17 | 2002| 16| 0| 0| 0| 0| 0| | |
18 | 2002| 17| | 36| 46| 56| 66| | |
19 | 2002| 18| 27| 37| 47| 57| | | |
20 | 2002| 19| 0| 0| 0| 0| 0| | |
21 | 2002| 20| 0| 0| 0| 0| 0| | |
22 | 2002| 21| 0| 0| 0| 0| 0| | |
23 | 2002| 22| 0| 0| 0| 0| 0| | |
24 | 2002| 23| 0| 0| 0| 0| 0| | |
25 | 2002| 24| 0| 0| 0| 0| 0| | |
26 | 2002| 25| 0| 0| 0| 0| 0| | |
27 | 2002| 26| 0| 0| 0| 0| 0| | |
28 | 2002| 27| 0| 0| 0| 0| 0| | |
29 | 2002| 28| 0| 0| 0| 0| 0| | |
30 | 2002| 29| 0| 0| 0| 0| 0| | |
尝试宏并研究我的代码。我已经解释了宏的每个部分的目标，但是我没有解释大部分的VBA语句，因为一旦知道它们存在就很容易查询语句。例如，尝试搜索“Excel VBA Option Explicit”。回过头来问一些问题，但你可以为自己制定的方案越多，开发速度就会越快。
Option Explicit
' Constants allow you to use names instead of literals that might change over
' time. You only have one header row and perhaps this will not change but
' it is better to avoid making such assumptions. If you ever do add a second
' header row, one change here will fix the macro.
Const RowDataFirst As Long = 2
' Columns can be letters or numbers with "A"=1, "B"=2, "C"=3 and so on
Const ColYear As Long = 1
Const ColWeek As Long = 2
Const ColDataFirst As Long = 3
' Change to your name for the worksheet containing the matrix
Const WshtName As String = "Data"
Sub CreateUnrecordedWeeks()
Dim ColCrnt As Long
Dim ColLast As Long
Dim RowCrnt As Long
Dim RowLast As Long
Dim RowValues() As Variant
Dim WeekCrnt As Long
Dim YearCrnt As Long
' This stops the screen being repainted everytime a row is inserted
Application.ScreenUpdating = False
' "Cells(1, 1).CurrentRegion" requires/assumes that the user has started the
' macro with the correct worksheet active. This may be very likely in this
' case but it is is a bad habit to make this assumption so best not to start.
' Use a With statement to specify the worksheet unless there is an
' operational reason why using the worksheet selected by the user is
' appropriate.
With Worksheets(WshtName)
' Excel VBA often provides several methods of achiving the same objective.
' There are several methods of finding the last row and or column none of
' which gives what the naive programmer might expect in every situation.
' Separate Finds for the last row and last column containing any value is
' the most reliable and I believe appropriate for your situation. In
' particular it allows some existing rows to have missing trailing values
' without this causing problrms for the macro.
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
' "Debug.Print" outputs values to the Immediate Window (at the bottom of the screen).
' I use Debug.Print to check values are as I expect before moving on to the next
' section of the macro.
'Debug.Print "RowLast " & RowLast
'Debug.Print "ColLast " & ColLast
' Validate existing rows have valid years and weeks in ascending order
'=====================================================================
' To add missing rows, the macro requires that, in every case, Row(N+1) is
' for a later year or week than Row(N). Validating that this requirement is
' met before starting the update avoiding creating a half updated matrix.
' For rows RowDataFirst to RowLast:
' 1) column A must hold a value in the range 2000 to 2099
' 2) column B must hold a value in the range 1 to 53
' 3) Cells(Row+1,"A") must be equal to or greater than Cells(Row,"A")
' 4) If Cells(Row+1,"A") equals Cells(Row,"A") then Cells(Row+1,"B")
' must be greater than Cells(Row,"B")
' Check the first data row here. Within loop check the second of each
' pair. This means each row is only checked once
If Not HasRowValidYearWeek(RowDataFirst) Then
' User has already been told of problem
' "Debug.Assert False" stops execution. I place it at the top of every path
' through my code. Once it has been reached, I comment it out. Any that remain
' when I have finished testing imply my testing has been inadequate.
'Debug.Assert False
Exit Sub
End If
' Check each data row (except the first) against the previous row
For RowCrnt = RowDataFirst + 1 To RowLast
If Not HasRowValidYearWeek(RowCrnt) Then
' User has already been told of problem
'Debug.Assert False
Exit Sub
End If
If .Cells(RowCrnt, ColYear) = .Cells(RowCrnt - 1, ColYear) Then
If .Cells(RowCrnt, ColWeek) > .Cells(RowCrnt - 1, ColWeek) Then
' Same year, increased week so current row belongs after previous row
'Debug.Assert False
ElseIf .Cells(RowCrnt, ColWeek) = .Cells(RowCrnt - 1, ColWeek) Then
'Debug.Assert False
Call MsgBox("Row " & RowCrnt & " has the same year" & _
" and week as the previous row.", vbOKOnly)
Exit Sub
Else
'Debug.Assert False
Call MsgBox("Row " & RowCrnt & _
" belongs before the previous row.", vbOKOnly)
Exit Sub
End If
ElseIf .Cells(RowCrnt, ColYear) > .Cells(RowCrnt - 1, ColYear) Then
' Increased year so current row belongs after previous row
'Debug.Assert False
Else
'Debug.Assert False
Call MsgBox("Row " & RowCrnt & _
" belongs before the previous row.", vbOKOnly)
End If
Next
'Debug.Print "Data OK"
' Generate a row of zeros for any row to be inserted. This row is the length
' of the longest existing row.
ReDim RowValues(1 To 1, 1 To ColLast)
' VBA allows a range to loaded to an array or an array to be loaded to a
' range with:
' 1) VariantArray = Range.Value
' 2) Range.Value = VariantArray
' With format 1, the interpreted ReDims VariantArray to match the range
' size. With format 2, The range and array sizes should match. I leave you
' to experiment to discover what happens if the the sizes do not match.
' VariantArray is a two dimensional array. The first dimension is for rows
' and the second for columns. The is the opposite of the normal convention
' but means the access matches Cells(Row, Column)
' RowValues(1, ColYear) and RowValues(1, ColWeek) will be overwritten when
' a row is inserted.
For ColCrnt = 1 To ColLast
RowValues(1, ColCrnt) = 0
Next
RowCrnt = 2
' The first row must be for week 1 of a year
YearCrnt = .Cells(RowCrnt, ColYear).Value
WeekCrnt = 0
' This is the main loop. It cannot be a For-Loop because rows will be
' inserted and the end value for a For-Loop can be changed within the loop.
' Each repeat of this loop does one of the following:
' 1) Determines that the next required row is already present and
' advances to the next row
' 2) Determines a mid-year is missing and inserts it. The previous
' current row remains the current row
' 3) Determines the current year is complete and prepares for the next
' 4) Determines a trailing week for a year is missing and adds it. The
' year previous current row remains the current row
Do While RowCrnt <= RowLast
If YearCrnt = .Cells(RowCrnt, ColYear).Value Then
' Have another row for the same year
'Debug.Assert False
WeekCrnt = WeekCrnt + 1
If WeekCrnt = .Cells(RowCrnt, ColWeek).Value Then
' The next row is already present
'Debug.Assert False
RowCrnt = RowCrnt + 1 ' Advance to next row
' No more processing for this loop
Else
' The next row is not present
'Debug.Assert False
.Rows(RowCrnt).Insert ' Insert row above RowCrnt
RowLast = RowLast + 1
RowValues(1, ColYear) = YearCrnt
RowValues(1, ColWeek) = WeekCrnt
.Range(.Cells(RowCrnt, 1), .Cells(RowCrnt, ColLast)).Value = RowValues
RowCrnt = RowCrnt + 1 ' Advance to previous current row
' No more processing for this loop
End If
Else
' Next row is for a different year
'Debug.Assert False
If WeekCrnt = 52 Or WeekCrnt = 53 Then
' YearCrnt is finished
'Debug.Assert False
YearCrnt = YearCrnt + 1
WeekCrnt = 0
' No more processing for this loop
Else
' A trailing week is missing. Add it.
'Debug.Assert False
WeekCrnt = WeekCrnt + 1
.Rows(RowCrnt).Insert ' Insert row above RowCrnt
RowLast = RowLast + 1
RowValues(1, ColYear) = YearCrnt
RowValues(1, ColWeek) = WeekCrnt
.Range(.Cells(RowCrnt, 1), .Cells(RowCrnt, ColLast)).Value = RowValues
RowCrnt = RowCrnt + 1 ' Advance to previous current row
' No more processing for this loop
End If
End If
Loop
End With
Application.ScreenUpdating = True
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
Dim ColCode As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = ColCode
End Function
Function HasRowValidYearWeek(ByVal RowCrnt As Long) As Boolean
' Return True if column ColYear of RowCrnt is in the range 2000-2099 and
' column ColWeek of RowCrnt is in the range 1-53
HasRowValidYearWeek = True
With Worksheets(WshtName)
If IsNumeric(.Cells(RowCrnt, ColYear).Value) Then
If .Cells(RowCrnt, ColYear).Value >= 2000 And _
.Cells(RowCrnt, ColYear).Value <= 2099 Then
'Debug.Assert False
' Column A of first data row has good value
Else
'Debug.Assert False
Call MsgBox("Cell " & ColNumToCode(ColYear) & RowCrnt & _
" is not in the range 2000-2099.", vbOKOnly)
HasRowValidYearWeek = False
End If
Else
'Debug.Assert False
Call MsgBox("Cell " & ColNumToCode(ColYear) & RowCrnt & _
" is not numeric.", vbOKOnly)
HasRowValidYearWeek = False
End If
If IsNumeric(.Cells(RowCrnt, ColWeek).Value) Then
If .Cells(RowCrnt, ColWeek).Value >= 1 And _
.Cells(RowCrnt, ColWeek).Value <= 53 Then
'Debug.Assert False
' Column A of first data row has good value
Else
'Debug.Assert False
Call MsgBox("Cell " & ColNumToCode(ColWeek) & RowCrnt & _
" is not in the range 1-53.", vbOKOnly)
HasRowValidYearWeek = False
End If
Else
'Debug.Assert False
Call MsgBox("Cell " & ColNumToCode(ColWeek) & RowCrnt & _
" is not numeric.", vbOKOnly)
HasRowValidYearWeek = False
End If
End With
End Function
你对“第一周”的定义是什么？从1月1日开始的七天？从一年的第一个星期一开始的一周？包含今年第一个星期四的一周？其中第三个是ISO定义，但前两个也很受欢迎。该定义确定哪些年份有第53周，因此在考虑添加缺失的周数之前必须知道。 –
@TonyDallimore，谢谢你的指挥。事实上，由于焦点确实在时间上，应该知道应该在哪里增加第53周。但是，我使用的数据集具有很强的季节性。在原始数据集中没有第53周。为了避免复杂的统计数据，并且看到第53周没有必要，我决定看到它不像一个日期那么多，将它添加到52 –