请教VBA实现内容提取合并问题

6xueren

请教一下，上图中如何用VBA实现下图效果，其中的开盘价为当日四个时间段中10:30的开盘价，最高价为当日四个时间段的最高价，最低价为当日四个时间段的最低价，收盘价为当日四个时间段中15:00的收盘价，成交量为当日四个时间段中的成交量的总和。



用以下代码出来的不太理想不知哪里的问题。
代码：

Sub ProcessData()
    Dim lastRow As Long
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
   
    ' 声明变量
    Dim currentDate As Date
    Dim currentOpen As Double
    Dim currentHigh As Double
    Dim currentLow As Double
    Dim currentClose As Double
    Dim currentVolume As Long
    Dim newRowIndex As Long
    Dim i As Long
   
    ' 设置起始行
    newRowIndex = 2
   
    ' 遍历数据
    For i = 2 To lastRow
        ' 获取当前行的日期和时间
        currentDate = Range("A" & i).Value
        
        ' 检查是否为新的日期
        If Format(currentDate, "hh:mm") = "10:30" Then
            ' 如果是新的日期，则将之前日期的数据写入新行
            If newRowIndex > 2 Then
                Range("H" & newRowIndex).Value = Format(currentDate, "yyyy/mm/dd")
                Range("I" & newRowIndex).Value = currentOpen
                Range("J" & newRowIndex).Value = currentHigh
                Range("K" & newRowIndex).Value = currentLow
                Range("L" & newRowIndex).Value = currentClose
                Range("M" & newRowIndex).Value = currentVolume
                newRowIndex = newRowIndex + 1
            End If
            
            ' 重置新日期的数据
            currentOpen = Range("B" & i).Value
            currentHigh = Range("C" & i).Value
            currentLow = Range("D" & i).Value
            currentClose = 0
            currentVolume = 0
        End If
        
        ' 更新当日的数据
        currentHigh = Application.WorksheetFunction.Max(currentHigh, Range("C" & i).Value)
        currentLow = Application.WorksheetFunction.Min(currentLow, Range("D" & i).Value)
        currentClose = Range("E" & i).Value
        currentVolume = currentVolume + Range("F" & i).Value
        
        ' 如果是最后一个时间段（15:00），则将数据写入新行
        If Format(currentDate, "hh:mm") = "15:00" Then
            Range("H" & newRowIndex).Value = Format(currentDate, "yyyy/mm/dd")
            Range("I" & newRowIndex).Value = currentOpen
            Range("J" & newRowIndex).Value = currentHigh
            Range("K" & newRowIndex).Value = currentLow
            Range("L" & newRowIndex).Value = currentClose
            Range("M" & newRowIndex).Value = currentVolume
            newRowIndex = newRowIndex + 1
        End If
        
        ' 如果是最后一行数据，则将当前日期的数据写入新行
        If i = lastRow Then
            Range("H" & newRowIndex).Value = Format(currentDate, "yyyy/mm/dd")
            Range("I" & newRowIndex).Value = currentOpen
            Range("J" & newRowIndex).Value = currentHigh
            Range("K" & newRowIndex).Value = currentLow
            Range("L" & newRowIndex).Value = currentClose
            Range("M" & newRowIndex).Value = currentVolume
        End If
    Next i
   
    ' 删除未使用的行
    Range("H" & newRowIndex + 1 & ":M" & lastRow).ClearContents
End Sub

鄂龙蒙

开盘价与收盘价要均价？

鄂龙蒙

汇总.rar (46.13 KB, 下载次数: 8)

2023-7-5 19:22 上传

点击文件名下载附件

6xueren

鄂龙蒙 发表于 2023-7-5 18:47
开盘价与收盘价要均价？

当日4个时间点最早的是开盘价，最晚的是收盘价

gwjkkkkk

请参考附件。。。

limonet

代码审核中。

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("adodb.connection")
    Cn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
    StrSQL = "select 日期,first(开盘价),max(最高价),min(最低价),last(收盘价),sum(成交量) from (select Int(日期) as 日期,开盘价,最高价,最低价,收盘价,成交量 from [Sheet1$A:F] where 日期>0) group by 日期"
    Range("H2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

6xueren

gwjkkkkk 发表于 2023-7-5 21:39
请参考附件。。。

程序精简而强大，可惜我这小白看不懂

6xueren

limonet 发表于 2023-7-5 22:18
Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("adodb.connection")

请教这代码在插入的对象文件中无法使用，已经把原代码里的sheet1改为工作表的名称sheet4，还是提示这个：

sdytsxd991122

参与一下