|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Dim wb As Workbook
- Dim ws As Worksheet
- Dim mypath$, myname$
- Dim rng As Range
- Set d = CreateObject("scripting.dictionary")
-
- With Worksheets("已入")
- r = .Cells(.Rows.Count, 16).End(xlUp).Row
- arr = .Range("p1:p" & r)
- For i = 2 To UBound(arr)
- d(arr(i, 1)) = Empty
- Next
- End With
-
- If Dir(ThisWorkbook.Path & "\未入库文件", vbDirectory) = "" Then
- MsgBox "未入库文件夹不存在!"
- Exit Sub
- End If
-
- If Dir(ThisWorkbook.Path & "\未入库文件\进货明细.xlsx") = "" Then
- MsgBox "进货明细.xlsx不存在!"
- Exit Sub
- End If
-
- Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\未入库文件\进货明细.xlsx")
- With wb
- With .Worksheets("23年进货明细")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:l" & r)
- ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
- m = 0
- For i = 1 To UBound(arr)
- If d.exists(arr(i, 10)) Then
- m = m + 1
- For j = 1 To UBound(arr, 2)
- brr(m, j) = arr(i, j)
- Next
- If rng Is Nothing Then
- Set rng = .Cells(i + 1, 1).Resize(1, 12)
- Else
- Set rng = Union(rng, .Cells(i + 1, 1).Resize(1, 12))
- End If
- End If
- Next
- If Not rng Is Nothing Then
- rng.Interior.ColorIndex = 23
- End If
- End With
- .Close True
- End With
- If m = 0 Then
- MsgBox "没有符合条件数据!"
- Exit Sub
- End If
-
-
- With ThisWorkbook.Worksheets("已入")
- .Range("a2:l" & .Rows.Count).Clear
- With .Range("a2").Resize(m, UBound(brr, 2))
- .Value = brr
- .Borders.LineStyle = xlContinuous
- With .Font
- .Name = "宋体"
- .Size = 10
- End With
- End With
- End With
-
- ReDim crr(1 To m, 1 To 10)
- For i = 1 To m
- crr(i, 1) = brr(i, 2)
- crr(i, 3) = brr(i, 4)
- crr(i, 4) = "Kg"
- crr(i, 5) = brr(i, 6)
- crr(i, 6) = brr(i, 8)
- crr(i, 7) = brr(i, 9)
- crr(i, 10) = brr(i, 10)
- Next
- With ThisWorkbook.Worksheets("入库")
- .UsedRange.Offset(2, 0).Clear
- With .Range("a3").Resize(m, UBound(crr, 2))
- .Value = crr
- .Borders.LineStyle = xlContinuous
- With .Font
- .Name = "宋体"
- .Size = 10
- End With
- End With
- End With
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|