提取包含关键字的内容。

cqz2022

提取关键内容.rar (43.81 KB, 下载次数: 3)

2024-1-20 15:42 上传

点击文件名下载附件

谢谢

明天会更好zj

哈哈

明天会更好zj

完善一点的代码，判断【b1】单元格数据是否为空，为空就不执行，如果有非法的表名字符，也不能执行，再一个，最后那里判断n值是否大于0，大于0才写入数据。

cqz2022

明天会更好zj 发表于 2024-1-20 09:20
完善一点的代码，判断【b1】单元格数据是否为空，为空就不执行，如果有非法的表名字符，也不能执行，再一个 ...

辛苦了  谢谢
2楼的代码 是不是没有 3楼提到的这些内容

蓝桥玄霜

提取的例子：

cqz2022

蓝桥玄霜 发表于 2024-1-20 10:48
提取的例子：

谢谢  这里一直报错   

cqz2022

明天会更好zj 发表于 2024-1-20 09:11

测试报错，辛苦 帮忙看看什么原因。

ykcbf1100

附件无法下载，请重新上传吧。

cqz2022

ykcbf1100 发表于 2024-1-20 15:14
附件无法下载，请重新上传吧。

提取关键内容.rar (43.81 KB, 下载次数: 7)

2024-1-20 15:41 上传

点击文件名下载附件

谢谢

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.20
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("参数")
   
5.     st = sh.[b1].Value
   
6.     b = [{6,2,3}]
   
7.     ReDim brr(1 To 1000, 1 To 3)
   
8.     p = ThisWorkbook.Path & "\数据库"
   
9.     For Each sht In Sheets
   
10.         If sht.Name = st Then sht.Delete
    
11.     Next
    
12.     For Each f In Fso.GetFolder(p).Files
    
13.         If f.Name Like "*.xlsx" Then
    
14.             fn = Fso.GetBaseName(f)
    
15.             Set wb = Workbooks.Open(f, 0)
    
16.             With wb.Sheets(1)
    
17.                 r = .Cells(Rows.Count, 1).End(3).Row
    
18.                 arr = .Range("a1:f" & r)
    
19.                 wb.Close False
    
20.             End With
    
21.             For i = 3 To UBound(arr)
    
22.                 s = arr(i, 2) & arr(i, 3)
    
23.                 If InStr(s, st) Then
    
24.                     m = m + 1
    
25.                     For j = 1 To UBound(b)
    
26.                         brr(m, j) = arr(i, b(j))
    
27.                     Next
    
28.                 End If
    
29.             Next
    
30.         End If
    
31.     Next f
    
32.     Sheets("模板").Copy after:=Sheets("参数")
    
33.     Set sht = ActiveSheet
    
34.     With sht
    
35.         .Name = st
    
36.         If m > 0 Then
    
37.             .[a2].Resize(m, 3) = brr
    
38.             .[a2].Resize(m, 3).EntireColumn.AutoFit
    
39.         End If
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    
44. 
    

复制代码