基于历史价格的当日股票价格分析V25.11.29

Sub D5555全部历史分析结果匹配ok()
    Dim wsOutput As Worksheet
    Dim wsSource As Worksheet
    Dim dict As Object
    Dim startTime As Double, totalTime As Double
    Dim lastRow As Long, lastRowsource As Long
    Dim I As Long, J As Integer
    Dim code As String
    Dim fileNames As Variant, outputColumns As Variant
    Dim matchCount() As Long
    Dim totalRows As Long
    Dim resultMsg As String
    Dim adjustType As Integer
    Dim sourceSheetName As String, FQLX As String
    Dim dataArray As Variant, tempArray() As Variant
    Dim Headers As Variant
    Dim maxPrice As Double, minPrice As Double, avgPrice As Double
    Dim latestPrice As Double, priceDiff As Double, diffRate As Double
    Dim priceRange As Double, volatility As Double
    Dim mainPrice As String, conclusion As String
    Dim dataDate As Date
    Dim analysisText As String
    Dim dashPos As Long, pipePos As Long
    Dim lowerBound As Double, upperBound As Double
    Dim latest As Double
    Dim finalText As String ' 添加缺失的变量声明

    '记录开始时间
    startTime = Timer
    
    '=== 初始化输出表 ===
    Set wsOutput = Worksheets("历史")
    If wsOutput Is Nothing Then
        MsgBox "错误：找不到工作表 '历史'"
        Exit Sub
    End If
    
    '设置表头
    Headers = Array("HF-后复权", "HF-前复权", "HF-不复权", _
                    "max", "min", "avg", "主要价格区间", "HF-二次分析", "五日价量金")
    
    '写入表头
    For I = 0 To UBound(Headers)
        wsOutput.Cells(7, I + 6).Value = Headers(I) '从F列开始
    Next I
    
    '获取输出表最后一行
    lastRow = wsOutput.Cells(wsOutput.Rows.count, "B").End(xlUp).Row
    If lastRow < 8 Then
        MsgBox "错误：输出表中数据不足"
        Exit Sub
    End If
    totalRows = lastRow - 7
    
    '=== 步骤一：通过code匹配所有复权类型 ===
    Application.StatusBar = "步骤一：匹配所有复权类型..."
    
    fileNames = Array("FX后（zqb）", "FX前（zqb）", "FX不（zqb）")
    outputColumns = Array("F", "G", "H")
    ReDim matchCount(0 To UBound(fileNames))
    
    For J = 0 To UBound(fileNames)
        Set dict = CreateObject("Scripting.Dictionary")
        
        '检查数据源工作表
        On Error Resume Next
        Set wsSource = ThisWorkbook.Sheets(fileNames(J))
        On Error GoTo 0
        
        If Not wsSource Is Nothing Then
            '获取数据源最后一行
            lastRowsource = wsSource.Cells(wsSource.Rows.count, "B").End(xlUp).Row
            
            '加载数据到字典
            For I = 1 To lastRowsource
                If Not IsEmpty(wsSource.Cells(I, "F")) Then
                    code = Trim(wsSource.Cells(I, "F").Value)
                    If code <> "" And Not dict.exists(code) Then
                        '确保值为字符串类型
                        dict.Add code, CStr(wsSource.Cells(I, "R").Value)
                    End If
                End If
            Next I
            
            '匹配数据到输出表
            For I = 8 To lastRow
                code = Trim(wsOutput.Cells(I, "C").Value)
                If code <> "" And dict.exists(code) Then
                    wsOutput.Cells(I, outputColumns(J)).Value = dict(code)
                    matchCount(J) = matchCount(J) + 1
                Else
                    wsOutput.Cells(I, outputColumns(J)).Value = "未下载"
                End If
            Next I
        Else
            MsgBox "警告：数据源 " & fileNames(J) & " 不存在"
        End If
        
        Set dict = Nothing
        Set wsSource = Nothing
    Next J
    
    '=== 步骤二：选择复权类型，匹配核心基础数据 ===
    Application.StatusBar = "步骤二：选择复权类型..."
    
    '用户选择复权类型
    adjustType = Application.InputBox("请选择复权类型：" & vbNewLine & _
                                    "1 - 后复权" & vbNewLine & _
                                    "2 - 前复权" & vbNewLine & _
                                    "3 - 不复权", _
                                    "复权类型选择", 1, Type:=1)
    
    If adjustType < 1 Or adjustType > 3 Then
        MsgBox "取消操作！"
        Exit Sub
    End If
    
    '设置数据源
    Select Case adjustType
        Case 1: sourceSheetName = "FX后（zqb）": FQLX = "后复权"
        Case 2: sourceSheetName = "FX前（zqb）": FQLX = "前复权"
        Case 3: sourceSheetName = "FX不（zqb）": FQLX = "不复权"
    End Select
    
    '设置二次分析列表头
    wsOutput.Cells(7, "M").Value = "HF-" & FQLX & "二次分析"
    
    '加载选择的复权类型数据
    Set wsSource = Worksheets(sourceSheetName)
    If wsSource Is Nothing Then
        MsgBox "错误：数据源 " & sourceSheetName & " 不存在"
        Exit Sub
    End If
    
    Set dict = CreateObject("Scripting.Dictionary")
    lastRowsource = wsSource.Cells(wsSource.Rows.count, "F").End(xlUp).Row
    
    '加载详细数据到字典
    For I = 1 To lastRowsource
        If Not IsEmpty(wsSource.Cells(I, "F")) Then
            code = Trim(wsSource.Cells(I, "F").Value)
            If code <> "" And Not dict.exists(code) Then
                '重新定义动态数组
                ReDim tempArray(1 To 4)
                For J = 1 To 4
                    tempArray(J) = wsSource.Cells(I, 7 + J).Value ' H-K列数据;H列是第8列
                Next J
                dict.Add code, tempArray
            End If
        End If
    Next I
    
    '=== 步骤三：更新核心数据 ===
    Application.StatusBar = "步骤三：更新核心数据..."
    
    With wsOutput
        For I = 8 To lastRow
            code = Trim(.Cells(I, "C").Value)
            If code <> "" And dict.exists(code) Then
                '写入详细数据到I-L列
                dataArray = dict(code)
                For J = 1 To 4
                    If J <= UBound(dataArray) Then
                        .Cells(I, 8 + J).Value = dataArray(J) 'I-L列数据; I列是第9列
                    End If
                Next J
            End If
            
            '定期释放内存
            If I Mod 500 = 0 Then DoEvents
        Next I
    End With
    
    '=== 步骤四：重新分析记录 ===
    Application.StatusBar = "步骤四：重新分析记录..."
    
    With wsOutput
        For I = 8 To lastRow
            If .Cells(I, "L").Value <> "" And IsNumeric(.Cells(I, "E").Value) Then
                dataDate = .Cells(I, 2).Value
                latestPrice = .Cells(I, 5).Value
                latest = latestPrice
                
                '更新最高价（I列）
                maxPrice = Application.WorksheetFunction.Max(.Cells(I, 9).Value, latestPrice)
                .Cells(I, 9).Value = maxPrice
                
                '更新最低价（J列）- 修正列号
                minPrice = Application.WorksheetFunction.Min(.Cells(I, 10).Value, latestPrice)
                .Cells(I, 10).Value = minPrice ' 原来是16，应该是10
                
                '安全获取数值
                On Error Resume Next
                avgPrice = CDbl(.Cells(I, 11).Value)
                mainPrice = CStr(.Cells(I, 12).Value)
                On Error GoTo 0
                
                priceDiff = latestPrice - avgPrice
                If avgPrice <> 0 Then
                    diffRate = priceDiff / avgPrice
                Else
                    diffRate = 0
                End If
                
                priceRange = maxPrice - minPrice
                If minPrice <> 0 Then
                    volatility = maxPrice / minPrice
                Else
                    volatility = 0
                End If
                
                '写入新结论
                conclusion = ""
                finalText = ""
                
                '处理破新高/创新低
                If latestPrice = maxPrice Then
                    conclusion = "破新高；"
                ElseIf latestPrice = minPrice Then
                    conclusion = "创新低；"
                End If
                
                '处理主要价格区间检查
                If mainPrice <> "" And IsNumeric(latest) Then
                    dashPos = InStr(1, mainPrice, "-")
                    pipePos = InStr(1, mainPrice, "|")
                    
                    If dashPos > 0 And pipePos > 0 Then
                        lowerBound = Val(Mid(mainPrice, 1, dashPos - 1))
                        upperBound = Val(Mid(mainPrice, dashPos + 1, pipePos - dashPos - 1))
                        
                        If latest >= lowerBound And latest <= upperBound Then
                            conclusion = conclusion & "主要价格区间内；"
                        End If
                    End If
                End If
                
                '基于差异率进行分析判断
                If diffRate <> 0 Then
                    If diffRate < -0.5 Then
                        conclusion = conclusion & "显著低于均值,原因？"
                        .Cells(I, "M").Font.Color = RGB(0, 0, 255) '蓝色
                    ElseIf diffRate >= -0.5 And diffRate < -0.2 Then
                        conclusion = conclusion & "探底反转？"
                        .Cells(I, "M").Font.Color = RGB(0, 0, 255) '蓝色
                    ElseIf diffRate >= -0.2 And diffRate < 0 Then
                        conclusion = conclusion & "负接近均值；"
                        .Cells(I, "M").Font.Color = RGB(255, 0, 0) '红色
                    ElseIf diffRate >= 0 And diffRate < 0.1 Then
                        conclusion = conclusion & "正接近均值；"
                        .Cells(I, "M").Font.Color = RGB(255, 0, 0) '红色
                    ElseIf diffRate >= 0.1 And diffRate < 0.3 Then
                        conclusion = conclusion & "可以观察；"
                        .Cells(I, "M").Font.Color = RGB(0, 0, 0) '黑色
                    ElseIf diffRate >= 0.3 And diffRate < 0.5 Then
                        conclusion = conclusion & "稍高于avg！"
                        .Cells(I, "M").Font.Color = RGB(0, 0, 0) '黑色
                    Else
                        conclusion = conclusion & "远高于均值！"
                        .Cells(I, "M").Font.Color = RGB(0, 0, 0) '黑色
                    End If
                End If
                
                ' 构建详细分析文本
                analysisText = FQLX & "ZQB二次分析：[" & Format(dataDate, "yyyymmdd") & "]；" & vbCrLf & _
                            "【结论】：" & conclusion & "；" & vbCrLf & _
                            "NP：[" & latestPrice & "]；AvgP：[" & avgPrice & "]；" & vbCrLf & _
                            "较avg差异：[" & priceDiff & "]；差异率：" & Format(diffRate, "0.00%") & "；" & vbCrLf & _
                            "Min：[" & minPrice & "]；Max：[" & maxPrice & "]；" & vbCrLf & _
                            "高低差：[" & priceRange & "]；波动率：" & Format(volatility, "0.00%") & "；" & vbCrLf & _
                            "主要价格：[" & mainPrice & "]；"
                
                ' 写入分析结论到M列
                .Cells(I, "M").Value = analysisText
                
                ' 确保M列文本自动换行
                .Cells(I, "M").WrapText = True
            End If
            
            '定期释放内存
            If I Mod 500 = 0 Then DoEvents
        Next I
    End With
    
    '完成处理
    totalTime = Timer - startTime
    Application.StatusBar = "处理完成！总耗时：" & Format(totalTime, "0.00") & "秒"
    
    '确保MsgBox显示
    On Error Resume Next
    MsgBox "处理完成！" & vbNewLine & _
           "后复权匹配：" & matchCount(0) & "条" & vbNewLine & _
           "前复权匹配：" & matchCount(1) & "条" & vbNewLine & _
           "不复权匹配：" & matchCount(2) & "条" & vbNewLine & _
           "总耗时：" & Format(totalTime, "0.00") & "秒", vbInformation, "处理结果"
    On Error GoTo 0
End Sub