7,785
社区成员




Option Explicit
Private Type DataInfo
Comment() As String
ID_List() As String
Title As String
MaxSN As Long
End Type
Private arrDataList() As DataInfo
Private mlListMaxSN As Long
Private mlListMaxUBD As Long
Private Sub LoadData()
Dim objExcel As Object
Dim objDocWBK As Object
Dim objDocSht As Object
Dim strName As String
Dim strTemp As String
Dim lPartID As Long
Dim lNullCount As Long
Dim lListPnt As Long
Dim i&, k&, w As Long
mlListMaxSN = -1&
On Error GoTo E_FinalExit
Set objExcel = CreateObject("Excel.Application")
' 从哪个文档加载数据,按你的实际情况更改:
Set objDocWBK = objExcel.Workbooks.Open("E:\Temp\数据信息.xlsx", True)
Set objDocSht = objDocWBK.Sheets("Sheet1")
mlListMaxUBD = 7&
ReDim arrDataList(mlListMaxUBD)
strName = vbLf ' 随便设置一个“不可能”且不为空的初值
lPartID = 0&
lListPnt = -1&
lNullCount = 0&
i = 1& ' 数据从“第1行”开始
Do
strTemp = objDocSht.Cells(i, 1).Value
If ("" = strTemp) Then
lNullCount = 1& + lNullCount
If (5& = lNullCount) Then ' 检测到“连续5个空行”判定数据结束
mlListMaxSN = lListPnt
arrDataList(lListPnt).MaxSN = k
Exit Do
End If
Else
lNullCount = 0&
If (strTemp <> strName) Then
If (-1& < lListPnt) Then arrDataList(lListPnt).MaxSN = k
strName = strTemp
lListPnt = 1& + lListPnt
If (lListPnt > mlListMaxUBD) Then
mlListMaxUBD = 4& + mlListMaxUBD
ReDim Preserve arrDataList(mlListMaxUBD)
End If
k = 0&: w = 7&
ReDim arrDataList(lListPnt).ID_List(w)
ReDim arrDataList(lListPnt).Comment(w)
arrDataList(lListPnt).Title = strName
Else
k = 1& + k
If (k > w) Then
w = 8& + w
ReDim Preserve arrDataList(lListPnt).Comment(w)
ReDim Preserve arrDataList(lListPnt).ID_List(w)
End If
End If
arrDataList(lListPnt).ID_List(k) = objDocSht.Cells(i, 2).Value
arrDataList(lListPnt).Comment(k) = objDocSht.Cells(i, 3).Value
End If
i = 1& + i
Loop
E_FinalExit:
Set objDocSht = Nothing
Call objDocWBK.Close(False)
Set objDocWBK = Nothing
Call objExcel.Quit
Set objExcel = Nothing
End Sub