按关键字筛选内容，添加序号，并在每行下面增加空白行

ykcbf1100

参与一下。。。

leeson7502

参与一下

1. Sub ExtractData()
   
2.     On Error Resume Next
   
3.     Dim ws As Worksheet
   
4.     Dim arr(), arrtemp(), arrStr() As String
   
5.     Set ws = ThisWorkbook.Sheets("签证单格式化")
   
6.     arr = ws.Range("A1").CurrentRegion
   
7.     For i = 1 To UBound(arr)
   
8.         If InStr(arr(i, 1), "月") Then
   
9.             ReDim Preserve arrtemp(0 To 1, 0 To k)
   
10.             arrStr = Split(arr(i, 1), ".")
    
11.             arrtemp(0, k) = Trim(arrStr(0))
    
12.             arrtemp(1, k) = Trim(arrStr(1))
    
13.             k = k + 2
    
14.         End If
    
15.     Next
    
16.     Set ws = ThisWorkbook.Sheets("Sheet2")
    
17.    
    
18.     With ws
    
19.         .Cells.Clear
    
20.         .Cells(1, 1).Resize(UBound(arrtemp, 2) + 1, 2) = _
    
21.             Application.WorksheetFunction.Transpose(arrtemp)
    
22.     End With
    
23.     MsgBox "Done!"
    
24.     ws.Activate
    
25. End Sub

复制代码

李伟杰123

LIUZHU 发表于 2023-12-5 09:22
请用WPS测试

序号没有放到单独一列