如果需要，如何让 Excel VBA 创建和填写数据

Question

1) 在 Excel 中编写一个语句，该语句将插入行并填充缺失任何时间的天数的缺失数据。 “DATE_HR”中的小时数应为 00-23（24 小时制）。

和

2) 对于在“DATE_HR” (DD-MMM-YYYY-HH) 下列出的小时数，缺少“0”（即“班级”中的 NDG）“1-4”、“GR”、和/或“CLASSIFICATION”中的“SB”，对于任何给定的小时，编写一个语句，该语句将在所有小时中插入并填充缺失的行，其中缺少“CLASSIFICATION”、“Class”、“DATE_HR”和“Total”（缺少的“TOTAL”行值应该为零，因为缺少的数据没有条目）。

下面是程序需要做的一个例子。左边是缺失数据表（之前），右边是校正表（之后），黄色为1，蓝色为2

-这是我到目前为止的进展：

我已经为这个问题编写了伪代码，并开始在 excel VBA 中编写。这是伪代码：

SR = Selected_row
RA = Row_above
C = Classification
DT = Date & Time
IR=Insert_row
# = Any number 1-4

Start on seleted row

Loop statement:
= IF(SRC = ”GR” AND RAC = 4 AND SRDT== RADT, SR,
OR(SRC = ”SB” AND RAC = “GR” AND SRDT== RADT, SR,
OR(SRC = 0 AND RAC = “SB” AND SRDT== RADT -1day/+22hour, SR,
OR(SRC = # AND RAC = SRC -1 AND SRDT == RADT, SR,
OR(SRC = 0 AND RADT = -1day of SRC/23hour, SRC = “0” AND SRDT= RADT +1day/00hour,IR AND
IF(RAC = ”SB” AND RADT = 23hour, SRC = “0” AND SRDT= RADT +1day/00hour,
OR (RAC = ”SB”, SRC = “0” AND SRDT= RADT +1hour,
OR (RAC = ”GR”, SRC = “SB” AND SRDT= RADT,
OR (RAC = 4, SRC = “GR” AND SRDT= RADT,
OR(RAC = # AND SRC = RAC +1 AND SRDT == RADT, SR         *here # = 0-3
)))))))))))))
Move onto next row below previous row
IF(SR=””, END program, continue)

这是 excel VBA 代码：（颜色只是看看它是否在做它应该做的事情）

子 IF_Loop()

Dim i As Long

For i = 2 To 155
    If (Range("B" & i).Value = "GR" And Range("B" & i - 1).Value = 4 And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
    (Range("B" & i).Value = "SB" And Range("B" & i - 1).Value = "GR" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
    (Range("B" & i).Value = "4" And Range("B" & i - 1).Value = "3" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
    (Range("B" & i).Value = "3" And Range("B" & i - 1).Value = "2" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
    (Range("B" & i).Value = "2" And Range("B" & i - 1).Value = "1" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
    (Range("B" & i).Value = "1" And Range("B" & i - 1).Value = "00" And Range("C" & i).Value = Range("C" & i - 1).Value) Then
        Rows(i & ":" & i).Interior.Color = 9359529
    Else
        'insert row and correct data
        Rows(i & ":" & i).EntireRow.Insert shift:=x1Down And _
        Rows(i & ":" & i)
    End If
Next i

我不确定如何编写剩余的代码。您如何正确编写剩余的行，以便代码执行所需的任务？

Answer 1

我会以不同的方式做这件事。

您需要知道您的开始和结束日期，并且您还需要拥有所有分类和相关类别的列表。 （我在宏中都进行了硬编码，但您可以使用其他方案）。

您可以从中创建一个表格，其中包含所有日期的所有课程和所有时间。

完成此操作后，您可以查看总计是否可用于分类/日期组合，然后将其写入零，如果不存在，则写入零。

我使用了一个包含信息的类对象。这些对象中的每一个都有一个包含所有 date_hr | 的集合（字典）。该分类可用的总组合，以及返回给定分类的类的方法。

使用 VBA 数组比对工作表进行多次读取/写入要快几个数量级。

希望我已经对代码进行了足够多的注释，以便您了解发生了什么。 有关类对象的精彩讨论，请参阅已故的 Chip Pearsons Introduction to Classes。 如果此链接失效，您需要进行网络搜索。还有一篇关于从工作表范围读取/写入数组的文章，您会发现它很有用。

仔细阅读cmets，尤其是在每个模块的开头，以便正确设置，否则将无法运行。

它确实假定您的数据有一个标题行，并以A1 开头。

结果放在同一个工作表上，但如何更改应该很明显。

类模块

'**Rename this module: cClass**
Option Explicit
Private pClass As String
Private pClassification As String
Private pDate_HR As Date
Private pDate_HRs As Dictionary

Public Property Get class() As String
    Select Case Me.Classification
    Case "1"
        class = "Freshman"
    Case "2"
        class = "Sophomore"
    Case "3"
        class = "Junior"
    Case "4"
        class = "Senior"
    Case "GR"
        class = "Graduate"
    Case "SB"
        class = "Second Bachelor"
    Case "0"
        class = "NDG"
    Case Else
        class = "N/A"
End Select
End Property


Public Property Get Classification() As String
    Classification = pClassification
End Property
Public Property Let Classification(Value As String)
    pClassification = Value
End Property

Public Property Get Date_HR() As Date
    Date_HR = pDate_HR
End Property
Public Property Let Date_HR(Value As Date)
    pDate_HR = Value
End Property

Public Property Get Date_HRs() As Dictionary
    Set Date_HRs = pDate_HRs
End Property
Public Function addDate_HRsItem(dtHR As Date, toTAL As Long)
        Date_HRs.Add Key:=dtHR, Item:=toTAL
End Function


Private Sub Class_Initialize()
    Set pDate_HRs = New Dictionary
        pDate_HRs.CompareMode = TextCompare
End Sub

常规模块

Option Explicit
'set reference to microsoft scripting runtime

Sub fillData()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim I As Long, J As Long
    Dim dD As Dictionary, cc As cClass
    Dim sKey As String, sDTkey As Date

'set source and results worksheets, range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 7)

'read source data into vba array
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With

'Process the known data
'collect it into a dictionary for fast lookups
Set dD = New Dictionary
    dD.CompareMode = TextCompare
For I = 2 To UBound(vSrc, 1)
    Set cc = New cClass
    With cc
        .Classification = vSrc(I, 1)
        .Date_HR = convDTHR(vSrc(I, 3))
        .addDate_HRsItem .Date_HR, CLng(vSrc(I, 4))
        sKey = .class

        If Not dD.Exists(sKey) Then
            dD.Add sKey, cc
        Else
            dD(sKey).addDate_HRsItem .Date_HR, CLng(vSrc(I, 4))
        End If
    End With
Next I

'Create Results Array
'Unclear from your question how many dates you want, so will
'  just do Mar 4

Const dtStart As Date = #3/4/2019#
Const dtEnd As Date = #3/5/2019#

'code the list of all Classifications
Dim arrClass
    arrClass = Array(0, 1, 2, 3, 4, "GR", "SB")
ReDim vRes(0 To (dtEnd - dtStart + 1) * 24 * (UBound(arrClass) + 1), 1 To 4)

'write the column Headers into a results array
For J = 1 To 4
    vRes(0, J) = vSrc(1, J)
Next J

'fill in other columns
For I = 1 To UBound(vRes, 1) Step UBound(arrClass) + 1
    For J = 0 To UBound(arrClass)
        vRes(I + J, 1) = arrClass(J) 'Classification
        vRes(I + J, 2) = convCLASS(arrClass(J)) 'class
        vRes(I + J, 3) = Format(dtStart + Int((I + J - 1) / (UBound(arrClass) + 1)) / 24, "dd-mmm-yyyy hh") 'The Date_hr
        sKey = vRes(I + J, 2) 'key into dictionary
        If dD.Exists(sKey) Then
            sDTkey = convDTHR(vRes(I + J, 3)) 'key into collection of date/totals within the dictionary item
            If dD(sKey).Date_HRs.Exists(sDTkey) Then
                vRes(I + J, 4) = dD(sKey).Date_HRs(sDTkey)
            Else
                vRes(I + J, 4) = 0
            End If
        Else
            vRes(I + J, 4) = 0
        End If
    Next J
Next I

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Columns(1).HorizontalAlignment = xlCenter
    .EntireColumn.AutoFit
End With

End Sub

Private Function convDTHR(strDTHR) As Date
    convDTHR = CDate(Left(strDTHR, 11)) + Right(strDTHR, 2) / 24
End Function

Private Function convCLASS(strClassification) As String
    Dim cc As cClass
Set cc = New cClass
With cc
    .Classification = strClassification
    convCLASS = .class
End With
End Function