一、结构异常 字典 数组棋盘法
先上图
要求：
1.给个选择区域窗口，只提取区域里面的数据，
2.按日期下面的4列从左到右,从上到下,提取完再提取下一个日期,( 1,產品編號2,工單號碼3工單数量,4日期)
3. 產品編號1005开头的不提取,
4, 產品編號和工單號碼相同,的只留最早日期
提取的结果：
產品編號
工單號碼
工單数量
日期
4554-729900-04B81104706500
1月10日
4554-729915-02T
8109486
500
1月10日
4554-729900-04T
8110470
6500
1月10日
Sub 提取数据2()
On Error Resume Next
Dim rng As Range, arr, i, j, k, da As Date, brr() As Variant, 棋盘() As Variant, 行数 As Long, item As Long, dic As Object, NewSht As Worksheet
Dim rn As Range, rnn As Range, FirstMon As Integer, LastMon As Integer, 起始 As String, 终止 As String
With Worksheets('SMT Schedule (2)')
Set rng = .UsedRange
Set rn = .Range(.Range('a1'), .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1))
End With
one:
起始 = Application.InputBox('请输入起始日期，如“2015-1-1”', '请输入起始日期', '2015-1-1', , , , , 2)
If 起始 = 'False' Then Exit Sub
Set rnn = rn.Find(CDate(起始), , , xlWhole)
If rnn Is Nothing Then MsgBox '起始日期不存在，请重新填写！', vbOKOnly 32, '错误': GoTo one Else FirstMon = rnn.Column
two:
终止 = Application.InputBox('请输入终止日期，如“2015-1-31”', '请输入终止日期', '2015-1-31', , , , , 2)
If 起始 = 'False' Then Exit Sub
Set rnn = rn.Find(CDate(终止), , , xlWhole)
If rnn Is Nothing Then MsgBox '终止日期不存在，请重新填写！', vbOKOnly 32, '错误': GoTo two Else LastMon = rnn.Column 3
arr = rng.Value '数组
For j = FirstMon To LastMon
For i = 3 To UBound(arr)
' If j = 34 Then Stop
If IsDate(arr(1, j)) Then da = arr(1, j) '如果是日期，则记录日期
If arr(i, 2) = '產品編號' And Len(arr(i, j)) > 0 Then
If Split(arr(i, j), '-')(0) = '1005' Then i = i 10: GoTo label
item = item 1
ReDim Preserve brr(1 To 4, 1 To item)
brr(1, item) = arr(i, j) '產品編號
ElseIf arr(i, 2) = '工單號碼' And Len(arr(i, j)) > 0 Then
brr(2, item) = arr(i, j) '工單號碼
ElseIf arr(i, 2) = '工單数量' And Len(arr(i, j)) > 0 Then
brr(3, item) = arr(i, j) '工單数量
brr(4, item) = da '日期
ElseIf arr(i, 2) = '產品編號' And Len(arr(i, j)) = 0 Then
i = i 10: GoTo label
End If
label:
Next
Next
Set dic = CreateObject('scripting.dictionary') '创建字典对象
For i = 1 To UBound(brr, 2)
If dic.Exists(CStr(brr(1, i) & brr(2, i))) Then '如果字典中存在此关键字
行数 = dic(CStr(brr(1, i) & brr(2, i)))
If CDate(棋盘(1, k)) < CDate(brr(4, i)) Then
棋盘(4, k) = 棋盘(4, k) '日期
棋盘(3, k) = 棋盘(3, k) brr(3, i) '工單数量
Else
棋盘(4, k) = brr(4, i) '日期
棋盘(3, k) = 棋盘(3, k) brr(3, i) '工單数量
End If
Else '否则
k = k 1 '计算
dic(CStr(brr(1, i) & brr(2, i))) = k '写入字典，关键为（產品編號、工單號碼），条目为计数
ReDim Preserve 棋盘(1 To 4, 1 To k)
棋盘(1, k) = brr(1, i) '產品編號
棋盘(2, k) = brr(2, i) '工單號碼
棋盘(3, k) = brr(3, i) '工單数量
棋盘(4, k) = brr(4, i) '日期
End If
Next
Application.DisplayAlerts = False
Worksheets('汇总').Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False '关闭刷新
Set NewSht = Worksheets.Add(After:=Worksheets(Worksheets.Count)) '新建工作表表
With NewSht
.Name = '汇总' '新建工作表命名为汇总
.Range('a1:d1') = Array('產品編號', '工單號碼', '工單数量', '日期')
.Range('a2').Resize(UBound(棋盘, 2), 4) = Application.WorksheetFunction.Transpose(棋盘) '导出
.Range(Range('d2'), Cells(Rows.Count, 'd').End(xlUp)).NumberFormatLocal = 'yyyy/m/d'
.Range('a1').CurrentRegion.EntireColumn.AutoFit '自动列宽
.Range('a1').CurrentRegion.Borders.LineStyle = xlContinuous '添加边框线
End With
Erase 棋盘 '清空数组
Application.ScreenUpdating = True '开启刷新
End Sub
