Exce信息提取
Exce信息提取
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
Exce信息提取的更多相关文章
- 会务准备期间材料准备工作具体实施总结 ----（vim技巧应用, python信息提取与整合, microsoft word格式调整批量化)
会务准备期间材料准备工作具体实施总结(vim, python, microsoft word) span.kw { color: #007020; font-weight: bold; } code ...
- 自然语言16.1_Python自然语言处理学习笔记之信息提取步骤&分块（chunking）
QQ:231469242 欢迎喜欢nltk朋友交流 http://www.cnblogs.com/undercurrent/p/4754944.html 一.信息提取模型 信息提取的步骤共分为五步,原 ...
- Python自然语言处理学习笔记之信息提取步骤&分块（chunking）
一.信息提取模型 信息提取的步骤共分为五步,原始数据为未经处理的字符串, 第一步:分句,用nltk.sent_tokenize(text)实现,得到一个list of strings 第二步:分词,[ ...
- 编写一个可配置的网页信息提取组件 （二）—— 优雅的.net core 配置系统
引言 在上篇文章(http://www.cnblogs.com/lightluomeng/p/7212577.html)中,初步实现了一个可配置的网页信息分析组件.但是由于是奔着解决事情的目的去的,所 ...
- Python网络爬虫与信息提取（二）—— BeautifulSoup
BeautifulSoup官方介绍: Beautiful Soup 是一个可以从HTML或XML文件中提取数据的Python库.它能够通过你喜欢的转换器实现惯用的文档导航,查找,修改文档的方式. 官方 ...
- Problem creating zip: Execution exce ption (and the archive is probably corrupt but I could not delete it): Java heap space -> [Help 1]
今天mvn编译的时候报错: [ERROR] Failed to execute goal org.apache.maven.plugins:maven-assembly-plugin:2.5.5:s ...
- ruby读取exce文件，使用roo---Gem
module SEquipsHelper #设备台账,从excel文件读取信息 require 'roo' #require 'roo-xls' #读取excel文件 # SEquipsHelper. ...
- Python自然语言处理---信息提取
1.数据 目前的数据总体上分为结构化和非结构化的数据.结构化的数据是指实体和关系的规范和可预测的组织.大部分的需要处理的数据都属于非结构化的数据. 2.信息提取 简言之就是从文本中获取信息意义的方法. ...
- CTF-Bugku-分析-信息提取
CTF-Bugku-分析-信息提取 最近刷题的时候看到了这道比较有趣的题.而且网上也没找到wp,所以分享一下我的思路. 信息提取: 题目链接:http://ctf.bugku.com/challeng ...
随机推荐
- mysql主从复制跳过错误
mysql主从复制,经常会遇到错误而导致slave端复制中断,这个时候一般就需要人工干预,跳过错误才能继续 跳过错误有两种方式: 1.跳过指定数量的事务: mysql>slave stop; m ...
- 一条命令修改Linux密码
方法一.直接使用passwd命令 /bin/echo newpass|/usr/bin/passwd --stdin username *注:该方式只适用于红帽系操作系统,比如centos,redha ...
- keras系列︱利用fit_generator最小化显存占用比率/数据Batch化
本文主要参考两篇文献: 1.<深度学习theano/tensorflow多显卡多人使用问题集> 2.基于双向LSTM和迁移学习的seq2seq核心实体识别 运行机器学习算法时,很多人一开始 ...
- 安全性测试AppScan工具使用实战20150920
Appscan是做安全性测试的一款工具,网上资料比较少,项目需要做安全性测试,用它做了web的扫描,可以发现一些问题,并且有原因分析和修复建议,感觉还不错,现在实战 1.打开工具,点击[文件]下的[新 ...
- pkcs#5和pkcs#7填充的区别
最近做到了关于加密和解密的部分. 使用算法AES的时候,涉及到数据填充的部分,数据的填充有很多种方案,用的比较多的有pkcs#5,pkcs#7, 下面的都是从网上转来的.结论就是在AES 的使用中,p ...
- 07----popo up 弹窗
弹窗: 绑定点击弹窗事件,js代码 弹出框的url设置 from django.forms.models import ModelChoiceField 进入ModelChoiceField 可看到 ...
- 【测试技术】websocket-client
Websocket Client 继续上周的议题.因为我不会写go,不会写websocket客户端,导致整个测试过程我是个完美的酱油党.上周我终于把客户端服务写好了. 选择Websokcet框架 现在 ...
- vc 实现一个 http Server
实现 http 的协议解析 以及封装 , 对应不同的访问地址, 调用绑定的处理程序 , #include "stdafx.h" #include "lyocomm\web ...
- BZOJ2131 免费的馅饼【线段树优化DP】
Input 第一行是用空格隔开的二个正整数,分别给出了舞台的宽度W(1到10^8之间)和馅饼的个数n(1到10^5). 接下来n行,每一行给出了一块馅饼的信息.由三个正整数组成,分别表示了每个馅饼落到 ...
- JSON 总结
<!--Json格式配置映射 直接能访问JSON文本数据--> <system.webServer> <staticContent> <mimeM ...