Excel信息提取
来源：互联网 发布：qq播放器官方下载 mac 编辑：程序博客网 时间：2024/06/05 15:58
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 = NothingEnd SubSub 清空当前两个表数据() 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 NextEnd SubFunction 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 WithEnd Function 0 0
- Excel信息提取
- Matlab 提取网页信息保存到Excel（正则表达式）
- 02.1#excel中数据中的信息提取（函数）
- 如何在EXCEL中提取身份证号码里的出生年月日、性别等，相关信息
- 在EXCEL中提取身份证号码里的出生年月日、性别等，相关信息
- EXCEL中如何提取身份证出生日期和性别信息以及检验身份证号码的正确性
- excel提取声母函数
- Excel数据提取问题
- Excel批量提取超链接
- Excel 提取超链接
- EXCEL字符提取
- excel文本提取
- 信息标记与信息提取
- 提取网络接口信息
- 提取身份证信息
- EML提取主题信息
- 数据库之提取信息
- 数据库之提取信息
- 【一周任务】JMS学习任务20170225
- myeclipse快捷键大全
- Windows SDK 10586 安装图
- Java求一个整数的二进制中1的个数
- Sinc滤波器
- Excel信息提取
- 再谈Android AsyncTask的优缺点
- 2.24 --- 2.25 动态规划专题小测 及 NOIP 2008 模拟 总结
- 【原创亲测】win7下pip默认镜像源的配置
- <? extends T>和<? super T> 的解释
- android传感器
- Android签名生成和Android签名格式转换工具(MD5和SHA1签名)
- 分享几个可以有助失眠的方法
- 文章标题
