Excel信息提取

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub 信息汇总()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb0 As Workbook
    Dim sh0 As Worksheet, sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
    Dim ce As Range, ce_pic As Range
    Dim shp As Shape
    Dim arr(3) As String, brr(), crr(), drr()
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, dpic As Object, dbt As Object, dpic2 As Object
    新表 = ActiveWorkbook.Name
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    Set d3 = CreateObject("scripting.dictionary")
    Set d4 = CreateObject("scripting.dictionary")
    Set dpic = CreateObject("scripting.dictionary")    '图片
    Set dbt = CreateObject("scripting.dictionary")    '标题
    Set dpic2 = CreateObject("scripting.dictionary")    '标题

    d1.Add "均码", 7    '字典,后面的可以重复,但是前面的不可重复
    d1.Add "42cm", 8
    d1.Add "44cm", 9
    d1.Add "46-50cm", 10
    d1.Add "46cm", 11
    d1.Add "48cm", 12
    d1.Add "50-54cm", 13
    d1.Add "50cm", 14
    d1.Add "52cm", 15

    d2.Add "新生儿", 7    '字典,后面的可以重复,但是前面的不可重复
    d2.Add "3个月", 8
    d2.Add "6个月", 9
    d2.Add "9个月", 10
    d2.Add "01岁", 11
    d2.Add "02岁", 12
    d2.Add "03岁", 13
    d2.Add "04岁", 14
    d2.Add "06岁", 15
    d2.Add "08岁", 16
    d2.Add "10岁", 17
    d2.Add "均码", 18

    arr(1) = "销售"
    arr(2) = "本地库存"
    arr(3) = "公司库存"
    Set wb0 = Application.Workbooks(新表)    '动态名称
    'Set wb0 = Application.Workbooks("新表格式")    '动态名称
    Set wb1 = Application.Workbooks.Open(ActiveWorkbook.Path & "\货号本.xlsx")    '
    '    Set wb1 = Application.Workbooks("货号本.xlsx")
    Set wb2 = Application.Workbooks.Open(ActiveWorkbook.Path & "\销售表.xlsx")    '
    '    Set wb2 = Application.Workbooks("销售表.xlsx")
    Set wb3 = Application.Workbooks.Open(ActiveWorkbook.Path & "\本地库存.xlsx")    '
    '   Set wb3 = Application.Workbooks("本地库存.xlsx")

    Set sh0 = wb0.Sheets("sheet1")
    Set sh02 = wb0.Sheets("sheet2")
    'Set sh1 = wb1.Sheets(1)
    Set sh2 = wb2.Sheets(1)
    Set sh3 = wb3.Sheets(1)

    For Each shp In sh0.Shapes    '清除掉现有图片
        If shp.TopLeftCell.Row > 5 Then shp.Delete
    Next
    For Each shp In sh02.Shapes
        If shp.TopLeftCell.Row > 5 Then shp.Delete
    Next
    For i = 2 To sh2.Range("E65536").End(3).Row
        If d3.exists(Replace(sh2.Range("E" & i).Value, "'", "")) Then
            d3(Replace(sh2.Range("E" & i).Value, "'", "")) = d3(Replace(sh2.Range("E" & i).Value, "'", "")) + 1
        Else
            d3.Add Replace(sh2.Range("E" & i).Value, "'", ""), sh2.Range("H" & i).Value    '销售表--存活编码+数量
        End If
    Next
    For i = 2 To sh3.Range("E65536").End(3).Row
        If d4.exists(Replace(sh3.Range("A" & i).Value, "'", "")) Then
            d4(Replace(sh3.Range("A" & i).Value, "'", "")) = d4(Replace(sh3.Range("K" & i).Value, "'", "")) + 1
        Else
            d4.Add Replace(sh3.Range("A" & i).Value, "'", ""), sh3.Range("K" & i).Value    '本地库存--货号+数量
        End If
    Next
    st_bh = 1
    For Each sh1 In wb1.Sheets
        If InStr(sh1.Cells(1, 1).Value, "款式图") Then
            '--------------------遍历第一行,找出关键词列------------------------------------------
            dpic.RemoveAll    '清空图片词典
            dbt.RemoveAll
            crr = Application.Transpose(Application.Transpose(sh1.Range("A1:Z1")))
            For bt_i = 1 To UBound(crr)
                dbt(crr(bt_i)) = bt_i    '标题加入字典
            Next
            pic_i = 0
            '------------------图片选择并加入词典---------低效率--------------------------
            For Each shp In sh1.Shapes
                If sh1.Cells(shp.TopLeftCell.Row, 1).MergeArea.Cells.Count = 1 Then
                    linName = sh1.Range(Replace(sh1.Cells(shp.TopLeftCell.Row, 1).MergeArea.Address, "A", Chr(64 + dbt("编号"))))    '只有一个单元格的情况;
                    'shp.Name = Left(shp.Name, 13) & Int(Rnd(10))
                    dpic(linName) = shp.Name
                Else
                    For Each linName In Application.Transpose(sh1.Range(Replace(sh1.Cells(shp.TopLeftCell.Row, 1).MergeArea.Address, "A", Chr(64 + dbt("编号")))))    '"B"
                        'shp.Name = Left(shp.Name, 13) & Int(Rnd(10))
                        dpic(linName) = shp.Name    '解决了合并单元格右侧有多个编号的问题
                    Next
                    If (sh1.Cells(shp.TopLeftCell.Row, 1).MergeArea.Address <> sh1.Cells(shp.BottomRightCell.Row, 1).MergeArea.Address) Then    '规避有合并单元格的问题
                        For Each linName In Application.Transpose(sh1.Range(Replace(sh1.Cells(shp.BottomRightCell.Row, 1).MergeArea.Address, "A", Chr(64 + dbt("编号")))))    '"B"
                            dpic(linName) = shp.Name    '解决了合并单元格右侧有多个编号的问题
                        Next
                        Debug.Print sh1.Cells(shp.TopLeftCell.Row, 1).MergeArea.Address, sh1.Cells(shp.BottomRightCell.Row, 1).MergeArea.Address
                    End If
                End If
            Next

            '-----------------------------------------------------
            If r1 = 0 Then r1 = 4    'r加1便是第五行;
            If r2 = 0 Then r2 = 4    'r加1便是第五行;
            st_1 = 2: st = 2    '每个工作簿中的目标工作表从第二行开始统计
            Do While sh1.Cells(st, dbt("颜色")).Value <> ""
                If sh1.Cells(st - 1, dbt("编号")).Value <> sh1.Cells(st, dbt("编号")).Value Then
                    'If sh1.Cells(st - 1, dbt("编号")).Value & sh1.Cells(st - 1, dbt("颜色")).Value <> sh1.Cells(st, dbt("编号")).Value & sh1.Cells(st, dbt("颜色")).Value Then
                    st_1 = st
                    st_3_1 = r1    '同一编号开始
                    st_3_2 = r2    '同一编号开始
                End If
                '下面是岁段的单独处理;
                Do While sh1.Cells(st, dbt("编号")).Value & sh1.Cells(st, dbt("颜色")).Value = sh1.Cells(st + 1, dbt("编号")).Value & sh1.Cells(st + 1, dbt("颜色")).Value    '当前颜色未到终点;
aa1:
                    huohao = sh1.Cells(st, dbt("货号")).Value    '货号
                    pdm = sh1.Cells(st, dbt("岁段")).Value    'Left(Right(huohao, 3), 2) '判断码
                    For i = 1 To 3    '对同一个货号进行3次判断,赋予三行岁段的值;       [我目前的困境是:由于st值和r都分流了一部分,剩下的如何对齐?]
                        If InStr(pdm, "cm") Or pdm = "均码" Then
                            rpd = 0
                            If sh02.Cells(r2 + i, 2).Value = "" Then sh02.Cells(r2 + i, 2).Value = sh1.Cells(st, dbt("编号")).Value    '编号
                            If sh02.Cells(r2 + i, 3).Value = "" Then sh02.Cells(r2 + i, 3).Value = sh1.Cells(st, dbt("品名")).Value    '品名
                            If sh02.Cells(r2 + i, 4).Value = "" Then sh02.Cells(r2 + i, 4).Value = sh1.Cells(st, dbt("颜色")).Value    '颜色
                            If sh02.Cells(r2 + i, 5).Value = "" Then sh02.Cells(r2 + i, 5).Value = sh1.Cells(st, dbt("牌价")).Value   '牌价
                            If sh02.Cells(r2 + i, 6).Value = "" Then sh02.Cells(r2 + i, 6).Value = arr(i)  '库存名
                            If i = 1 Then  '销售
                                If d3.exists(huohao) Then
                                    sh02.Cells(r2 + i, d1(pdm)).Value = d3(huohao)                                'sheet2岁段的赋值
                                End If
                            ElseIf i = 2 Then  '本地库存
                                If d4.exists(huohao) Then
                                    sh02.Cells(r2 + i, d1(pdm)).Value = d4(huohao)                                'sheet2岁段的赋值
                                End If
                            ElseIf i = 3 Then   '公司库存
                                kucun = sh1.Cells(st, dbt("库存")).Value    '库存
                                On Error Resume Next
                                If Asc("kucun") > 0 Then kucun = IIf(CLng(kucun) = 2042, "", kucun)
                                On Error GoTo 0
                                sh02.Cells(r2 + i, d1(pdm)).Value = kucun                                'sheet2岁段的赋值
                            End If
                        Else
                            rpd = 1
                            If sh0.Cells(r1 + i, 2).Value = "" Then sh0.Cells(r1 + i, 2).Value = sh1.Cells(st, dbt("编号")).Value    '编号
                            If sh0.Cells(r1 + i, 3).Value = "" Then sh0.Cells(r1 + i, 3).Value = sh1.Cells(st, dbt("品名")).Value    '品名
                            If sh0.Cells(r1 + i, 4).Value = "" Then sh0.Cells(r1 + i, 4).Value = sh1.Cells(st, dbt("颜色")).Value    '颜色
                            If sh0.Cells(r1 + i, 5).Value = "" Then sh0.Cells(r1 + i, 5).Value = sh1.Cells(st, dbt("牌价")).Value   '牌价
                            If sh0.Cells(r1 + i, 6).Value = "" Then sh0.Cells(r1 + i, 6).Value = arr(i)  '库存名
                            If i = 1 Then  '销售
                                If d3.exists(huohao) Then
                                    sh0.Cells(r1 + i, d2(pdm)).Value = d3(huohao)                              'sheet1岁段的赋值
                                End If
                            ElseIf i = 2 Then  '本地库存
                                If d4.exists(huohao) Then
                                    sh0.Cells(r1 + i, d2(pdm)).Value = d4(huohao)
                                End If
                            ElseIf i = 3 Then   '公司库存
                                kucun = sh1.Cells(st, dbt("库存")).Value    '库存
                                On Error Resume Next
                                If Asc("kucun") > 0 Then kucun = IIf(CLng(kucun) = 2042, "", kucun)
                                On Error GoTo 0
                                sh0.Cells(r1 + i, d2(pdm)).Value = kucun    'sheet1岁段的赋值
                            End If
                        End If
                    Next
                    st = st + 1    '挪到下一行;
                    If tf = 1 Then GoTo aa2:
                Loop
                '-------------多处理一次------------------------
                tf = 1  '断点位置;
                GoTo aa1:
aa2:
                tf = 0  '断点位置
                '----------------------------------------------------
                If sh0.Cells(r1 + 3, 2).Value <> "" Then r1 = r1 + 3    '每隔3个进行一次挪移;
                If sh02.Cells(r2 + 3, 2).Value <> "" Then r2 = r2 + 3    '每隔3个进行一次挪移;

                '        Debug.Print sh1.Cells(st - 1, dbt("编号")).Value, sh1.Cells(st, dbt("编号")).Value
                If sh1.Cells(st - 1, dbt("编号")).Value <> sh1.Cells(st, dbt("编号")).Value Then
                    st_2 = st - 1  '表1同一编号的最后一行;
                    st_4_1 = r1    '表0同一编号的最后一行
                    st_4_2 = r2    '表0同一编号的最后一行
                    '复制图片
                    st_mid2 = st_3_1 + 1    ' Int((st_3 + st_4) / 3) '目标图片位置行
                    st_mid2_2 = st_3_2 + 1    ' Int((st_3 + st_4) / 3) '目标图片位置行
                    'Debug.Print sh1.Cells(st - 1, dbt("编号")).Value
                    picName = dpic(sh1.Cells(st - 1, dbt("编号")).Value)
                    pic_i = pic_i + 1
                    sh1.Activate
                    sh1.Shapes(picName).CopyPicture
                    Debug.Print sh1.Cells(st - 1, dbt("编号")).Value
                    'Shell "cmd /c md c:\temp\"
                    With sh1.ChartObjects.Add(500, 0, sh1.Shapes(picName).Width * 3, sh1.Shapes(picName).Height * 3).Chart
                        .Paste
                        .Export "c:\tem.JPG"
                        .Parent.Delete
                    End With


                    If rpd = 1 Then
                        'sh1.Paste sh0.Cells(st_mid2, 1)
                        sh0.Shapes.AddPicture "c:\tem.JPG", True, True, 0, 0, 212, 105
                        picName = sh0.Shapes(sh0.Shapes.Count).Name  '解决掉组合图片
                        With sh0.Shapes(picName)
                            .Name = .Name & Rnd(1000)
                            '--------------------------------------------------------------
                            wt = sh0.Cells(st_mid2, 1).Width    '单元格区域宽度;
                            ht = sh0.Cells(st_mid2, 1).Height * (st_4_1 - st_3_1)    '单元格区域高度

                            bl = .Width / .Height
                            If wt / ht < bl Then
                                .Width = wt    ' sh0.Cells(st_mid2, 1).Width
                                .Height = .Width / bl
                                .Left = sh0.Cells(st_mid2, 1).Left    ' + 2
                                .Top = sh0.Cells(st_mid2, 1).Top + (ht - .Height) / 2
                            Else
                                .Height = ht
                                .Width = .Height * bl
                                .Top = sh0.Cells(st_mid2, 1).Top
                                .Left = sh0.Cells(st_mid2, 1).Left + (wt - .Width) / 2
                            End If
                        End With
                    Else
                        'sh1.Paste sh02.Cells(st_mid2_2, 1)
                        sh02.Shapes.AddPicture "c:\tem.JPG", True, True, 0, 0, 212, 105
                        If InStr(picName, "Group") Then
                            picName = sh02.Shapes(sh02.Shapes.Count).Name  '解决掉组合图片
                        End If
                        picName = sh02.Shapes(sh02.Shapes.Count).Name  '解决掉组合图片
                        With sh02.Shapes(picName)
                            .Name = .Name & Rnd(1000)
                            '--------------------------------------------------------------
                            wt = sh02.Cells(st_mid2, 1).Width    '单元格区域宽度;
                            ht = sh02.Cells(st_mid2, 1).Height * (st_4_2 - st_3_2)    '单元格区域高度

                            bl = .Width / .Height
                            If wt / ht < bl Then
                                .Width = wt    ' sh0.Cells(st_mid2, 1).Width
                                If Round(.Width / .Height, 2) <> Round(bl, 2) Then .Height = .Width / bl
                                .Left = sh02.Cells(st_mid2_2, 1).Left    ' + 2
                                .Top = sh02.Cells(st_mid2_2, 1).Top + (ht - .Height) / 2
                            Else
                                .Height = ht
                                If Round(.Width / .Height, 2) <> Round(bl, 2) Then .Width = .Height * bl
                                .Top = sh02.Cells(st_mid2_2, 1).Top
                                .Left = sh02.Cells(st_mid2_2, 1).Left + (wt - .Width) / 2
                            End If
                        End With
                    End If
                End If
            Loop
        End If
    Next
    MsgBox "已完成!!!"
    Set d1 = Nothing
    Set d2 = Nothing
    Set d3 = Nothing
    Set d4 = Nothing
    Set dpic = Nothing
    Set dbt = Nothing
End Sub
Sub 清空当前两个表数据()
    Dim wb As Workbook, sh As Worksheet, shp As Shape
    Set wb = ActiveWorkbook
    For Each sh In wb.Sheets
        sh.Range(sh.Cells(5, 1), sh.Cells(65536, 256)).ClearContents
        For Each shp In sh.Shapes
            If shp.TopLeftCell.Row > 5 Then shp.Delete
        Next
    Next
End Sub


Function chaxun(ByVal varFindValue As Variant, ByVal intFindColumn As Integer, Name$) As Boolean    '查询
    Dim myCell As Range
    chaxun = ""
    With Application.Workbooks(Name).Range
        For Each myCell In .Columns(intFindColumn).Cells
            If myCell.Value = varFindValue Then
                r = myCell.Row: c = myCell.Column
                chaxun = .Cells(r, c + 3)
                Exit For
            End If
        Next myCell
    End With
End Function




  • 0
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 打赏
    打赏
  • 0
    评论
随着汽车保有量的增长,越来越多的道路交通事故也给社会和人民造成了巨大的损失。其中,汽车驾驶人的危险驾驶行为是导致道路交通事故频频发生的主要原因。无人驾驶汽车因其无需人类驾驶操纵的特点具有广阔的应用前景。在无人驾驶汽车的行驶过程中,如何实时、鲁棒地提取行驶环境信息,以及在获得信息的基础上进行合理的运动决策是实现其安全、高效自主驾驶的关键,也是无人驾驶汽车研究中的难点和热点。论文依托国家自然科学基金重大研究计划项目(90920305)“无人驾驶车辆智能测试环境研究与开发”和中央高校基金创新团队项目(CHD2011TD006)“基于视觉信息的无人驾驶智能车辆关键技术研究”对无人驾驶汽车环境信息提取及运动决策方法展开研究,以实现无人驾驶汽车安全、高效、智能地行驶。本文的研究内容主要包括:(1)视觉图像数据采集模型和预处理研究。以无人驾驶汽车坐标系作为约束条件,建立视觉图像数据采集模型;针对图像采集质量易受行驶环境影响而造成特征难以提取的问题,研究多尺度Retinex图像增强算法和传统中值滤波算法的改进优化算法,并进行静态离线对比试验。(2)针对复杂道路环境下车道标线检测算法鲁棒性较差的问题,提出面向图像像素点的改进道路图像分割方法以深度挖掘车道标线轮廓信息;在此基础上提出基于抽样行双向扫描和成像模型约束候选特征点相结合的车道标线检测优化算法。为了实现车道标线检测与跟踪模块的有效切换,建立置信度判别模块和失效判别模块。(3)针对非结构化道路边界检测效率和鲁棒性之间难以平衡的问题,提出一种基于置信概率的分块分类方法提取道路边界的特征点,在此基础上运用改进的最小二乘法完成非结构化道路模型参数求解,并进行静态离线对比试验。(4)针对无人驾驶汽车对前方车辆识别定位准确性及稳定性要求高的问题,提出一种基于视觉传感器和64线三维激光雷达信息融合的前方车辆识别算法。通过融合64线三维激光雷达提取的障碍物位置信息,确定图像中前方车辆的感兴趣区域;以类Haar-HOG融合特征作为目标车辆描述方法,采用AdaBoost算法离线训练获得的级联分类器进行前方车辆辨识;对因遮挡问题未被识别出前方车辆的感兴趣区域,提出基于激光雷达坐标系下位置关系信息的再确认方法。(5)无人驾驶汽车运动决策建模方法研究。以宏观行驶规划为前提,在环境信息提取的基础上,结合无人驾驶汽车的自身运动状态,对其在微观动态交通环境下的两类基本运动模式进行深入研究,设计无人驾驶汽车运动模式的决策条件及对应目标量;在此基础上建立基于决策树的运动决策模型;最后,通过构建微观动态交通仿真环境对其进行合理性验证。(6)搭建基于上位机组件的无人驾驶汽车平台,并对其广义视觉传感系统参数进行标定,在此基础上进行道路试验,以验证论文提出的环境信息提取方法的有效性和运动决策模型的合理性。
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

zhanglei1371

你的鼓励将是我创作的最大动力

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付:¥1
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值