Excel信息提取之二

Sub 订单归纳()  
Dim sh1  As Worksheet, sh2 As Worksheet, sh3 As Worksheet  
Dim dic1 As Object, dic2 As Object  
Dim arr, brr, crr  
Dim wb As Workbook  
Set wb = ActiveWorkbook  
Set sh1 = wb.Sheets("订单")  
Set sh2 = wb.Sheets("订单归纳")  
Set dic1 = CreateObject("scripting.dictionary")  
Set dic2 = CreateObject("scripting.dictionary")  
Dend = sh1.Range("D65536").End(3).Row  
    For i = 4 To Dend  
    strA = sh1.Range("D" & i) & "--" & Split(sh1.Range("F" & i).Value, " ")(0)  
        If Not dic1.exists(strA) Then  
            dic1.Add strA, sh1.Range("I" & i)  
        Else  
            dic1(strA) = dic1(strA) + sh1.Range("I" & i)  
        End If  
    Next  
    A = dic1.keys: B = dic1.items  
    For i = 0 To UBound(A) ' dic.Count - 1  
        s1 = Split(A(i), "--")(0)  
        s2 = Mid(Split(A(i), "--")(1), 6) & "--" & B(i)  
        If Not dic2.exists(s1) Then  
            dic2.Add s1, s2  
        Else  
            p1 = Replace(Split(dic2(s1), "--")(0), "/", "-") & "/" & Replace(Mid(Split(A(i), "--")(1), 6), "/", "-") 'Split(s2, "--")(0)  
            p2 = Split(dic2(s1), "--")(1) & "+" & B(i)  
              
        dic2(s1) = p1 & "--" & p2  
        End If  
    Next  
        A = dic2.keys: B = dic2.items  
        For i = 0 To UBound(A)  
            sh2.Range("A" & i + 2) = A(i)  
            sh2.Range("C" & i + 2).NumberFormatLocal = "m/d"  
            sh2.Range("C" & i + 2) = Split(B(i), "--")(0)  
            sh2.Range("B" & i + 2) = Split(B(i), "--")(1)  
        Next  
End Sub  
  
Sub 配件归纳()  
Dim sh1  As Worksheet, sh2 As Worksheet, sh3 As Worksheet  
Dim dic1 As Object, dic2 As Object  
Dim arr, brr, crr  
Dim wb As Workbook  
Set wb = ActiveWorkbook  
Set sh1 = wb.Sheets("目录")  
Set sh2 = wb.Sheets("订单归纳")  
Set sh3 = wb.Sheets("配件归纳")  
Set dic1 = CreateObject("scripting.dictionary")  
Set dic2 = CreateObject("scripting.dictionary")  
  
sh3.Range("A2:Z10000").ClearContents  
sh3.Range("A2:Z10000").UnMerge  
Cend = sh1.Range("C65536").End(3).Row  
For Each va In sh1.Range("C3:C" & Cend).Value  
If va <> "" Then dic1.Add va, Application.WorksheetFunction.Match(va, sh1.Range("C:C").Value, 0)  
Next  
  
Aend = sh2.Range("A65536").End(3).Row  
For Each va In sh2.Range("A2:A" & Aend).Value  
    If dic1.exists(va) Then  
        co = Application.WorksheetFunction.Match(va, sh1.Range("C:C").Value, 0)  
        N = sh1.Range("C" & co).MergeArea.Count  
        sh1.Range("A" & co & ":I" & co + N - 1).Copy  
        en = sh3.Range("A65536").End(3).Row  
        en = sh3.Range("A" & en).MergeArea.Count - 1 + en  
        sh3.Range("A" & en + 1).Select  
        sh3.Range("A" & en + 1).PasteSpecial xlPasteAll  
        sh3.Range("B" & en + N).MergeArea.Delete (xlToLeft)  
        sh3.Range("I" & en + 1 & ":I" & en + N).Merge  
        sh3.Range("I" & en + 1).Value = Application.WorksheetFunction.VLookup(va, sh2.Range("A2:C" & Aend), 2)  
        he = 0  
        For Each s In Split(sh3.Range("I" & en + 1).Value, "+")  
            he = he + CLng(s)  
        Next  
        For i = 1 To N  
             sh3.Range("J" & i + en).Value = he  
             sh3.Range("L" & i + en).Value = "=K" & en + 1 & "-J" & en + 1  
        Next  
        sh3.Range("N" & en + 1 & ":N" & en + N).Merge  
        sh3.Range("N" & en + 1).Value = Application.WorksheetFunction.VLookup(va, sh2.Range("A2:C" & Aend), 3)  
         sh3.Range("N" & en + 1).NumberFormatLocal = "m/d"  
         sh3.Range("L" & en + 1).NumberFormatLocal = "G/通用格式"  
        sh3.Range("O" & en + 1 & ":O" & en + N).Merge  
        If InStr(sh3.Range("N" & en + 1).Value, "星期") = 0 And InStr(sh3.Range("N" & en + 1).Value, "/") > 0 Then  
        zh = ""  
            For Each strB In Split(sh3.Range("N" & en + 1).Value, "/")  
                zh = zh & "/" & Abs(DateDiff("d", CDate(strB), Now()))  
            Next  
            sh3.Range("O" & en + 1).Value = Mid(zh, 2)  
        Else  
            sh3.Range("O" & en + 1).Value = DateDiff("d", Split(sh3.Range("N" & en + 1), " ")(0), Now())  
        End If  
         'sh3.Range("O" & en + 1).  
    Else  
      sh3.Range("P2").Value = "目录中无此型号"  
      sh3.Range("P2").Interior.Color = 255  
      If sh3.Range("Q2").Value = "" Then  
        sh2.Range("A1:C1").Copy  
        sh3.Range("Q2").PasteSpecial xlPasteAll  
      End If  
      ro = Application.WorksheetFunction.Match(va, sh2.Range("A:A"), 0)  
      sh2.Range("A" & ro & ":C" & ro).Copy  
      Qend = sh3.Range("Q65536").End(3).Row  
      sh3.Range("Q" & Qend).PasteSpecial xlPasteAll  
    End If  
Next  
MsgBox "已完成！!!"  
End Sub  
  
</pre><pre code_snippet_id="2300632" snippet_file_name="blog_20170330_3_5549772" name="code" class="vb"></pre><br>  
<pre code_snippet_id="2300632" snippet_file_name="blog_20170330_4_4263017" name="code" class="vb">文件选择函数  
Public Function ChooseOneFile(Optional TitleStr As String = "选择你要的文件", Optional TypesDec As String = "所有文件", Optional Exten As String = "*.*") As String  
Dim dlgOpen As FileDialog  
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)  
With dlgOpen  
.Title = TitleStr  
.Filters.Clear '清除所有的文件类型.  
.Filters.Add TypesDec, Exten  
.AllowMultiSelect = False '不能多选.  
If .Show = -1 Then  
' .AllowMultiSelect = True '多个文件  
' For Each vrtSelectedItem In .SelectedItems  
' MsgBox "Path name: " & vrtSelectedItem  
' Next vrtSelectedItem  
ChooseOneFile = .SelectedItems(1) '第一个文件  
End If  
End With  
Set dlgOpen = Nothing  
End Function  
复制所有的东西：  
    Sheets("sheet3").Range("C2").CopyFromRecordset cn.Execute("select * from [数据2$]") '这里是将所有的都复制过来,若是特定的则需distinct  
’设置日期格式：  
Sheets("数据1").Columns("C:C").NumberFormatLocal = "yyyy-mm-dd"  
Sheets("数据2").Columns("I:I").NumberFormatLocal = "G/通用格式"  
直接从数据源复制数据：可实现汇总并去重；  
  Sheets("数据1").Range("A2").CopyFromRecordset cn.Execute("select distinct 产品名称,图号,完成日期 from [数据$A7:H10000]")  
      设置日期显示格式：  
    '完成日期.Value = Month(完成日期.Value) & "." & Day(完成日期.Value)  
    '完成日期.NumberFormatLocal = "G/通用格式"  
    完成日期.NumberFormatLocal = "m-d;@"  
下面的使用方式非常精妙，将单元格的range进行设定，然后通过使用Excel公式的方式赋值，大大减小的代码量；  
    Set 图号 = Sheets("数据1").Range("B" & i)  
    Set 计划数量 = Sheets("数据1").Range("D" & i)  
    Set 完成日期 = Sheets("数据1").Range("C" & i)  
    Set 备注 = Sheets("数据1").Range("E" & i)  
    备注.Value = Application.WorksheetFunction.VLookup(图号.Value, Sheets("数据").Range("D:H"), 5, False)  
    计划数量.Value = "=SUMIFS(数据!E:E,数据!C:C,数据1!A" & i & ",数据!D:D,数据1!B" & i & ",数据!F:F,数据1!C" & i & ")"  
    计划数量.Value = 计划数量.Value ’这里的作用就是起到公式==>数值的作用；  
删除指定条件的单元格行  
    If Sheets("数据1").Range("D" & i) = 0 Then Sheets("数据1").Rows(i).Delete  
按条件筛选备注：  
    Sheets("数据2").Range("E" & i).CopyFromRecordset cn.Execute("select distinct 备注 from [数据$A7:H10000] where 图号 = '" & 图号 & "' and 产品名称 = '" & 产品名称 & "'")  
按条件筛选日期：  
    Sheets("数据2").Range("G1").CopyFromRecordset cn.Execute("select distinct 完成日期 from [数据$A7:H10000] where 图号 = '" & 图号 & "' and 产品名称 = '" & 产品名称 & "' order by 完成日期")  
下面方式直接得到的是值，而非输入的公式：  
    备注.Value = Application.WorksheetFunction.VLookup(图号.Value, Sheets("数据").Range("D:H"), 5, False)  
'判断是否存在目录,否则就创建：  
    If Len(Dir(myFolder, vbDirectory)) = 0 Then   
        MkDir myFolder  
    End If  
Excel输出图片的经典方法：  
    shp.CopyPicture  
    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart  
        .Paste  
        .Export myFolder & nm, "JPG"  
        .Parent.Delete  
    End With