VBA 每行保留特定字符的单元格

On_fire · 发表于 2024-4-10 17:19

VBA 每行保留特定字符的单元格

*

Sheet1是源数据,

每行是一组数据, 每行的A列是标题列

行列是变量

*

代码的逻辑如下,

1. 每行B列开始顺序左到右, 保留含指定的字符的单元格

2. 指定的字符: 如..教授, 导师, 博士, 硕士, 同时每行去空

*

Sheet1(2)是模拟结果

*

恳请大神, 老师出手帮忙...谢谢!

yanglinzi · 发表于 2024-4-10 17:43

请测试。。

yanglinzi · 发表于 2024-4-10 17:44

Sub 排列()
Dim arr, brr, i, j, d
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.UsedRange
For i = 1 To UBound(arr)
s = arr(i, 1)
For j = 2 To UBound(arr, 2)
If arr(i, j) <> Empty Then
If InStr(arr(i, j), "学员") = 0 Then
d(s) = d(s) & "," & arr(i, j)
End If
End If
Next
Next
ReDim brr(1 To d.Count, 1 To UBound(arr, 2))
For Each k In d.keys
n = n + 1
brr(n, 1) = k
xa = Split(d(k), ",")
For j = 1 To UBound(xa)
brr(n, j + 1) = xa(j)
Next
Next
Sheet2.Cells.ClearContents
Sheet2.[a1].Resize(n, UBound(brr, 2)) = brr
End Sub

复制代码

swl4561255 · 发表于 2024-4-10 18:21

Sub test()
Dim myr As Range
For i = 1 To 4
For j = 2 To 9
If Cells(i, j) Like "*" & "学员" & "*" Then
If myr Is Nothing Then
Set myr = Cells(i, j)
Else
Set myr = Union(myr, Cells(i, j))
End If
End If
Next
Next
myr.ClearContents
ActiveSheet.Cells.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete shift:=xlToLeft
End Sub

复制代码

limonet · 发表于 2024-4-10 18:52

只能XY循环判断

limonet · 发表于 2024-4-10 18:53

Sub limonet()
Dim Arr As Variant, i%, j%, k%, Brr() As Variant
Arr = Range("B1:I4")
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr)
      k = 0
      For j = 1 To UBound(Arr, 2)
         If Arr(i, j) <> "" And InStr("教授,导师,博士,硕士", Right(Arr(i, j), 2)) Then
            k = k + 1
            Brr(i, k) = Arr(i, j)
         End If
      Next j
Next i
Range("B5").Resize(UBound(Arr), UBound(Arr, 2)) = Brr
End Sub

gwjkkkkk · 发表于 2024-4-10 18:57

Option Explicit
Sub TEST2()
Dim ar, i&, j&, regEx As Object, Rng As Range

Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = "教授|导师|博士|硕士"

Cells.Clear
With Sheets(1).UsedRange
      ar = .Value
      For i = 1 To UBound(ar)
         Set Rng = .Cells(i, 1)
         For j = 2 To UBound(ar, 2)
            If regEx.test(ar(i, j)) Then Set Rng = Union(Rng, .Cells(i, j))
         Next j
         Rng.Copy Cells(i, 1)
      Next i

End With

Set regEx = Nothing
Beep
End Sub

gwjkkkkk · 发表于 2024-4-10 18:58

参与一下。。。

LIUZHU · 发表于 2024-4-10 19:09

JSA代码

function test(){
let n=0,arr=Sheets.Item("Sheet1").UsedRange.Value2;
let res=arr.map(x=>x.reduce((temp,y,i)=>(i>0 && /教授|导师|博士|硕士/.test(y)?temp.push(y):null,temp),[x[0]]));
let m=res.reduce((len,x)=>len=x.length>len?x.length:len,0); //最大维度
Sheets.Item("效果").Activate();
Range("a1").Resize(res.length,m).Value2=res;
}

复制代码

LIUZHU · 发表于 2024-4-10 19:10

请用WPS测试

		自动登录	找回密码
密码			免费注册

[求助] VBA 每行保留特定字符的单元格

评分

评分