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 = "目錄中無(wú)此型號(hào)" 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">文件選擇函數(shù) 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 '清除所有的文件類(lèi)型. .Filters.Add TypesDec, Exten .AllowMultiSelect = False '不能多選. If .Show = -1 Then ' .AllowMultiSelect = True '多個(gè)文件 ' For Each vrtSelectedItem In .SelectedItems ' MsgBox "Path name: " & vrtSelectedItem ' Next vrtSelectedItem ChooseOneFile = .SelectedItems(1) '第一個(gè)文件 End If End With Set dlgOpen = Nothing End Function 復(fù)制所有的東西： Sheets("sheet3").Range("C2").CopyFromRecordset cn.Execute("select * from [數(shù)據(jù)2$]") '這里是將所有的都復(fù)制過(guò)來(lái),若是特定的則需distinct ’設(shè)置日期格式： Sheets("數(shù)據(jù)1").Columns("C:C").NumberFormatLocal = "yyyy-mm-dd" Sheets("數(shù)據(jù)2").Columns("I:I").NumberFormatLocal = "G/通用格式" 直接從數(shù)據(jù)源復(fù)制數(shù)據(jù)：可實(shí)現(xiàn)匯總并去重； Sheets("數(shù)據(jù)1").Range("A2").CopyFromRecordset cn.Execute("select distinct 產(chǎn)品名稱(chēng),圖號(hào),完成日期 from [數(shù)據(jù)$A7:H10000]") 設(shè)置日期顯示格式： '完成日期.Value = Month(完成日期.Value) & "." & Day(完成日期.Value) '完成日期.NumberFormatLocal = "G/通用格式" 完成日期.NumberFormatLocal = "m-d;@" 下面的使用方式非常精妙，將單元格的range進(jìn)行設(shè)定，然后通過(guò)使用Excel公式的方式賦值，大大減小的代碼量； Set 圖號(hào) = Sheets("數(shù)據(jù)1").Range("B" & i) Set 計(jì)劃數(shù)量 = Sheets("數(shù)據(jù)1").Range("D" & i) Set 完成日期 = Sheets("數(shù)據(jù)1").Range("C" & i) Set 備注 = Sheets("數(shù)據(jù)1").Range("E" & i) 備注.Value = Application.WorksheetFunction.VLookup(圖號(hào).Value, Sheets("數(shù)據(jù)").Range("D:H"), 5, False) 計(jì)劃數(shù)量.Value = "=SUMIFS(數(shù)據(jù)!E:E,數(shù)據(jù)!C:C,數(shù)據(jù)1!A" & i & ",數(shù)據(jù)!D:D,數(shù)據(jù)1!B" & i & ",數(shù)據(jù)!F:F,數(shù)據(jù)1!C" & i & ")" 計(jì)劃數(shù)量.Value = 計(jì)劃數(shù)量.Value ’這里的作用就是起到公式==>數(shù)值的作用； 刪除指定條件的單元格行 If Sheets("數(shù)據(jù)1").Range("D" & i) = 0 Then Sheets("數(shù)據(jù)1").Rows(i).Delete 按條件篩選備注： Sheets("數(shù)據(jù)2").Range("E" & i).CopyFromRecordset cn.Execute("select distinct 備注 from [數(shù)據(jù)$A7:H10000] where 圖號(hào) = '" & 圖號(hào) & "' and 產(chǎn)品名稱(chēng) = '" & 產(chǎn)品名稱(chēng) & "'") 按條件篩選日期： Sheets("數(shù)據(jù)2").Range("G1").CopyFromRecordset cn.Execute("select distinct 完成日期 from [數(shù)據(jù)$A7:H10000] where 圖號(hào) = '" & 圖號(hào) & "' and 產(chǎn)品名稱(chēng) = '" & 產(chǎn)品名稱(chēng) & "' order by 完成日期") 下面方式直接得到的是值，而非輸入的公式： 備注.Value = Application.WorksheetFunction.VLookup(圖號(hào).Value, Sheets("數(shù)據(jù)").Range("D:H"), 5, False) '判斷是否存在目錄,否則就創(chuàng)建： If Len(Dir(myFolder, vbDirectory)) = 0 Then MkDir myFolder End If Excel輸出圖片的經(jīng)典方法： shp.CopyPicture With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart .Paste .Export myFolder & nm, "JPG" .Parent.Delete End With

　　

轉(zhuǎn)載于:https://www.cnblogs.com/zhanglei1371/p/6664813.html

總結(jié)

以上是生活随笔為你收集整理的Excel信息提取之二的全部?jī)?nèi)容，希望文章能夠幫你解決所遇到的問(wèn)題。

如果覺(jué)得生活随笔網(wǎng)站內(nèi)容還不錯(cuò)，歡迎將生活随笔推薦給好友。