比较复杂的检索后复制粘贴

ykcbf1100

sampsonpon 发表于 2024-7-24 17:49
老师，有没有必要加一句：And InStr(f.Name, "~$") = 0，当碰到临时文件时

我改一下吧，文件夹自选，这样更通用一点。

ykcbf1100

更新一下，文件夹改为自选

1. Sub ykcbf()    '//2024.7.24
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set reg = CreateObject("VBScript.Regexp")
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set sh = ThisWorkbook.Sheets("Org2")
   
8.     With Application.FileDialog(msoFileDialogFolderPicker)
   
9.         .Title = "请选择文件夹"
   
10.         .InitialFileName = ThisWorkbook.path & ""
    
11.         If .Show = -1 Then
    
12.             p = .SelectedItems(1) & ""
    
13.         End If
    
14.     End With
    
15.     With reg
    
16.         .Global = False
    
17.         .Pattern = "Read|CY|HQ|RFI"
    
18.     End With
    
19.     For Each f In fso.GetFolder(p).Files
    
20.         If LCase$(f.Name) Like "*.xls*" Then
    
21.             fn = fso.GetBaseName(f)
    
22.             If Not d.exists(fn) Then
    
23.                 If Not reg.TEST(fn) Then
    
24.                     d(fn) = ""
    
25.                     Set wb = Workbooks.Open(f, 0)
    
26.                     With wb.Sheets(1)
    
27.                         r1 = .Cells(Rows.Count, 1).End(3).Row
    
28.                         arr = .[a2].Resize(r1 - 1, 23)
    
29.                     End With
    
30.                     wb.SaveAs p & fn & "-Read"
    
31.                     wb.Close
    
32.                     r = sh.Cells(Rows.Count, 1).End(3).Offset(1).Row
    
33.                     sh.Cells(r, 1).Resize(UBound(arr), 23) = arr
    
34.                     fso.deletefile f
    
35.                 End If
    
36.             End If
    
37.         End If
    
38.     Next f
    
39.     Set d = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码