大神们按照图片实现这个功能 改改代码，谢谢

透明世界1987

供应商交期追踪表 - 副本.zip (201.51 KB, 下载次数: 3)

2022-1-17 14:48 上传

点击文件名下载附件
如上图实现这个功能改改代码

风林火山

1. Sub test()
   
2.     Dim arr, brr(), k As Integer, i As Byte, str As String, date1, date2, n As Integer
   
3.     arr = Sheet9.Range("A2").CurrentRegion
   
4.     str = Sheet3.Range("B2")
   
5.     date1 = Sheet3.Range("D2")
   
6.     date2 = Sheet3.Range("E2")
   
7.     For k = 3 To UBound(arr)
   
8.         If arr(k, 1) = str And arr(k, 7) >= date1 And arr(k, 7) <= date2 Then
   
9.             n = n + 1
   
10.             ReDim Preserve brr(1 To 15, 1 To n)
    
11.             For i = 1 To 7
    
12.                 brr(i, n) = arr(k, i)
    
13.             Next i
    
14.             brr(8, n) = arr(k, 12)
    
15.             brr(12, n) = arr(k, 8)
    
16.             brr(13, n) = arr(k, 9)
    
17.         End If
    
18.     Next k
    
19.     Sheet3.Range("a4:m200").ClearContents
    
20.     Sheet3.Range("a4").Resize(n, 15) = Application.WorksheetFunction.Transpose(brr)
    
21. End Sub
    

复制代码