关于查找到符合条件的，然后筛选复制

sampsonpon

关于查找到符合条件的，然后筛选复制，详细如图描述：

ykcbf1100

楼主的附件都没有摸拟结果，猜一个吧。

ykcbf1100

附件供参考。。。

1. Sub ykcbf()  '//2024.5.17
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""   '//这个到时改为你自己实际的路径
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     rq = Date
   
7.     nf = Year(rq): yf = Month(rq)
   
8.     Select Case yf
   
9.         Case Is <= 3
   
10.             fn = nf & "年 1月-3月"
    
11.         Case Is <= 6
    
12.             fn = nf & "年 4月-6月"
    
13.         Case Is <= 9
    
14.             fn = nf & "年 7月-9月"
    
15.         Case Else
    
16.             fn = nf & "年 10月-12月"
    
17.     End Select
    
18.     p1 = p & nf & "自制扫描时间记录"
    
19.     f = p1 & fn & "自制HU扫描时间记录.xlsm"
    
20.     Set wb = Workbooks.Open(f, 0)
    
21.     With wb.Sheets("自制来货时间")
    
22.         r = .Cells(Rows.Count, 1).End(3).Row
    
23.         If r = 1 Then
    
24.             MsgBox "数据文件没有内容！"
    
25.             Exit Sub
    
26.         End If
    
27.         arr = .[a1].Resize(r, 2)
    
28.     End With
    
29.     wb.Close 0
    
30.     ReDim brr(1 To r, 1 To 1)
    
31.     For i = 2 To UBound(arr)
    
32.         If arr(i, 2) = rq Then
    
33.             m = m + 1
    
34.             brr(m, 1) = arr(i, 1)
    
35.         End If
    
36.     Next
    
37.     With sh
    
38.         .[a7:a1000] = ""
    
39.         .[a7].Resize(m, 1) = brr
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    
44. 
    

复制代码

sampsonpon

ykcbf1100 发表于 2024-5-17 16:13
附件供参考。。。

很牛！结果完全正确！不过最后不是贴到A7，想让它在剪切板上也就是*.COPY

sampsonpon

ykcbf1100 发表于 2024-5-17 16:13
附件供参考。。。

结果是对的无任何问题，就是最后这句不用，我不需要它贴到这里，我只需要把它们COPY到剪切板上即可：*.copy

    With sh
        .[a7:a1000] = ""
        .[a7].Resize(m, 1) = brr
    End With

ykcbf1100

sampsonpon 发表于 2024-5-17 17:08
结果是对的无任何问题，就是最后这句不用，我不需要它贴到这里，我只需要把它们COPY到剪切板上即可：*.co ...

不需要的话，你删除即可。

ykcbf1100

sampsonpon 发表于 2024-5-17 16:36
很牛！结果完全正确！不过最后不是贴到A7，想让它在剪切板上也就是*.COPY

你把结果copy一下即可。

sampsonpon

ykcbf1100 发表于 2024-5-17 19:48
你把结果copy一下即可。

请给个*.COPY代码，因为我SAP代码里需要来粘贴这些值

sampsonpon

ykcbf1100 发表于 2024-5-17 16:13
附件供参考。。。

    With sh
        .[a7:a1000] = ""
        .[a7].Resize(m, 1) = brr
    End With
省略掉这句，给个.copy暂放到剪切板上。谢谢！

longwin

sampsonpon 发表于 2024-5-19 18:44
With sh
        .[a7:a1000] = ""
        .[a7].Resize(m, 1) = brr

这样试试：
With sh
        .[a7:a1000] = ""
        .[a7].Resize(m, 1) = brr
        .range(“”A7:A“ & m).copy
    End With