Sub 订单归纳()Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As WorksheetDim dic1 As Object, dic2 As ObjectDim arr, brr, crrDim wb As WorkbookSet wb = ActiveWorkbookSet 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) NextEnd SubSub 配件归纳()Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As WorksheetDim dic1 As Object, dic2 As ObjectDim arr, brr, crrDim wb As WorkbookSet wb = ActiveWorkbookSet 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").ClearContentssh3.Range("A2:Z10000").UnMergeCend = sh1.Range("C65536").End(3).RowFor Each va In sh1.Range("C3:C" & Cend).ValueIf va <> "" Then dic1.Add va, Application.WorksheetFunction.Match(va, sh1.Range("C:C").Value, 0)NextAend = sh2.Range("A65536").End(3).RowFor 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 IfNextMsgBox "已完成！!!"End Sub
文件选择函数
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
