本帖最后由 网络人 于 2017-9-25 17:47 编辑
Sub 正单()
Application.ScreenUpdating = False
Dim x, y, m, n, o, p, q, r, s, t, arr, ARR1(1 To 30000, 1 To 39), ARR2(1 To 30000, 1 To 39), ARR3(1 To 30000, 1 To 39), ARR4(1 To 30000, 1 To 39), ARR5(1 To 30000, 1 To 39), ARR6(1 To 30000, 1 To 39), ARR7(1 To 30000, 1 To 39), ARR8(1 To 30000, 1 To 39)
Dim WB As Workbook
'** 使用FileDialog对象来选择文件夹
Dim strPath As String '选择文件路径
strPath = Application.GetOpenFilename(FileFilter:= _
"Excel Files(*.xls;*.xlsx),*.*", Title:="请选择文件")
'** 取消则退出
If Len(Dir(strPath)) = 0 Then Exit Sub
Set WB = Workbooks.Open(Filename:=strPath)
y = WB.Sheets("正单").[Match(1, 0 / (D:D <> ""))]
arr = WB.Sheets("正单").Range("A4:AH" & y) 这个地方要遍历“正单、样品单、补单”三个工作表的VBA代码修改
For x = 1 To UBound(arr, 1)
If 2 <= Now - arr(x, 14) And arr(x, 4) <> "" And arr(x, 14) <> "" And arr(x, 16) = "" And arr(x, 34) = "" Then
m = m + 1
For y = 1 To UBound(arr, 2)
ARR1(m, y) = arr(x, y)
Next y
End If
If 2 <= Now - arr(x, 16) And arr(x, 4) <> "" And arr(x, 16) <> "" And arr(x, 17) = "" And arr(x, 34) = "" Then
n = n + 1
For y = 1 To UBound(arr, 2)
ARR2(n, y) = arr(x, y)
Next y
End If
If 1 <= Now - arr(x, 17) And arr(x, 4) <> "" And arr(x, 17) <> "" And arr(x, 18) = "" And arr(x, 34) = "" Then
o = o + 1
For y = 1 To UBound(arr, 2)
ARR3(o, y) = arr(x, y)
Next y
End If
If 3 <= Now - arr(x, 18) And arr(x, 4) <> "" And arr(x, 18) <> "" And arr(x, 19) = "" And arr(x, 34) = "" Then
p = p + 1
For y = 1 To UBound(arr, 2)
ARR4(p, y) = arr(x, y)
Next y
End If
If 2 <= Now - arr(x, 19) And arr(x, 4) <> "" And arr(x, 19) <> "" And arr(x, 20) = "" And arr(x, 34) = "" Then
q = q + 1
For y = 1 To UBound(arr, 2)
ARR5(q, y) = arr(x, y)
Next y
End If
If 1 <= Now - arr(x, 20) And arr(x, 4) <> "" And arr(x, 20) <> "" And arr(x, 22) = "" And arr(x, 34) = "" Then
r = r + 1
For y = 1 To UBound(arr, 2)
ARR6(r, y) = arr(x, y)
Next y
End If
If 3 <= Now - arr(x, 22) And arr(x, 4) <> "" And arr(x, 22) <> "" And arr(x, 23) = "" And arr(x, 34) = "" Then
s = s + 1
For y = 1 To UBound(arr, 2)
ARR7(s, y) = arr(x, y)
Next y
End If
Next x
WB.Close True
Set WB = Nothing
With ThisWorkbook
.Sheets(1).Range("A4:AH" & y).ClearContents
If m > 0 Then
.Sheets(1).Range("B4").Resize(m, 17) = ARR1
.Sheets(1).Range("A4:AI" & m + 2).Borders.LineStyle = xlContinuous
.Sheets(1).Range("A4").Resize(m, 15).Sort key1:=.Sheets(1).[O4], Header:=xlNo
End If
.Sheets(2).Range("A4:AH" & y).ClearContents
If n > 0 Then
.Sheets(2).Range("B4").Resize(n, 18) = ARR2
.Sheets(2).Range("A4:AI" & n + 2).Borders.LineStyle = xlContinuous
.Sheets(2).Range("A4").Resize(n, 17).Sort key1:=.Sheets(2).[Q4], Header:=xlNo
End If
.Sheets(3).Range("A4:AH" & y).ClearContents
If o > 0 Then
.Sheets(3).Range("B4").Resize(o, 19) = ARR3
.Sheets(3).Range("A4:AI" & o + 2).Borders.LineStyle = xlContinuous
.Sheets(3).Range("A4").Resize(o, 18).Sort key1:=.Sheets(3).[r4], Header:=xlNo
End If
.Sheets(4).Range("A4:AH" & y).ClearContents
If p > 0 Then
.Sheets(4).Range("B4").Resize(p, 20) = ARR4
.Sheets(4).Range("A4:AI" & p + 2).Borders.LineStyle = xlContinuous
.Sheets(4).Range("A4").Resize(p, 19).Sort key1:=.Sheets(4).[S4], Header:=xlNo
End If
.Sheets(5).Range("A4:AH" & y).ClearContents
If q > 0 Then
.Sheets(5).Range("B4").Resize(q, 21) = ARR5
.Sheets(5).Range("A4:AI" & q + 2).Borders.LineStyle = xlContinuous
.Sheets(5).Range("A4").Resize(q, 20).Sort key1:=.Sheets(5).[T4], Header:=xlNo
End If
.Sheets(6).Range("A4:AH" & y).ClearContents
If r > 0 Then
.Sheets(6).Range("B4").Resize(r, 23) = ARR6
.Sheets(6).Range("A4:AI" & r + 2).Borders.LineStyle = xlContinuous
.Sheets(6).Range("A4").Resize(r, 21).Sort key1:=.Sheets(6).[U4], Header:=xlNo
End If
.Sheets(7).Range("A4:AH" & y).ClearContents
If s > 0 Then
.Sheets(7).Range("B4").Resize(s, 24) = ARR7
.Sheets(7).Range("A4:AI" & s + 2).Borders.LineStyle = xlContinuous
.Sheets(7).Range("A4").Resize(s, 23).Sort key1:=.Sheets(7).[W4], Header:=xlNo
End If
End With
Application.ScreenUpdating = True
End Sub
- Set WB = Workbooks.Open(Filename:=strPath)
- xrr = Array("正单", "样品单", "补单")
- For Each shnm In xrr
- y = WB.Sheets(shnm).[Match(1, 0 / (D:D <> ""))]
- arr = WB.Sheets(shnm).Range("A4:AH" & y)
- For x = 1 To UBound(arr, 1)
- ' .......
- Next
- Next
复制代码
|