求一VBA代码

feng0012 · 发表于 2020-9-8 15:38

请大神看附件

，请大神看附件

3190496160 · 发表于 2020-9-8 16:28

Sub test()
ar = Sheet1.[a1].CurrentRegion
Dim br()
ReDim br(1 To UBound(ar), 1 To 12)
For i = 3 To UBound(ar)
zf = ""
For j = 4 To 15
      If InStr(ar(i, j), "BZ") > 0 Then
         If zf = "" Then
            zf = ar(i, j) & "|" & ar(i, j + 1)
         Else
            zf = zf & "|" & ar(i, j) & "|" & ar(i, j + 1)
         End If
      End If
Next j
If zf <> "" Then
      n = n + 1
      rr = Split(zf, "|")
      For s = 0 To UBound(rr)
         br(n, s + 1) = rr(s)
      Next s
End If
Next i
With Sheets("结果")
.[a1].CurrentRegion = Empty
.[a1].Resize(n, UBound(br, 2)) = br
End With
End Sub

3190496160 · 发表于 2020-9-8 16:29

新建一个工作表，命名为结果，然后运行代码，切记
楼主模拟的结果是否有误？既然是需要筛选包含BZ字符的，为什么还会有其他的在结果中呢？？？？

鄂龙蒙 · 发表于 2020-9-8 16:30

找出来的分列显示是什么规则？

feng0012 · 发表于 2020-9-8 17:19

3190496160 发表于 2020-9-8 16:28
Sub test()
ar = Sheet1.[a1].CurrentRegion
Dim br()

非常感谢，先测试一下。

feng0012 · 发表于 2020-9-8 17:20

鄂龙蒙发表于 2020-9-8 16:30
找出来的分列显示是什么规则？

楼上大大的那个可以达到效果，效果就是附件那样显示

鄂龙蒙 · 发表于 2020-9-8 17:40

Sub 查找()
Dim m, n, i, j, arr, brr, crr()
Range("AC3:AJ24") = ""
arr = Range("D3:O24").Value
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
n = 0
For j = 1 To UBound(arr, 2) Step 2
If InStr(arr(i, j), "BZ") Then
n = n + 2
brr(i, n - 1) = arr(i, j)
brr(i, n) = arr(i, j + 1)
End If
Next
Next
m = 0
ReDim crr(1 To UBound(arr), 1 To 12)
For i = 1 To UBound(brr)
If brr(i, 1) <> "" Then
m = m + 1
For j = 1 To 12
crr(m, j) = brr(i, j)
Next
End If
Next
If m > 0 Then [AC3].Resize(m, 12) = crr
End Sub

复制代码

鄂龙蒙 · 发表于 2020-9-8 17:42

查找.rar (20.57 KB, 下载次数: 8)

feng0012 · 发表于 2020-9-9 11:13

鄂龙蒙发表于 2020-9-8 17:42

灰常感谢，

，两位大神达方法均留有备用

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