有条件提取数据，谢谢gwjkkkkk和excel玉米老师！

lhj323323

老师


上传的附件里，除了数据源外，只有文字说明
实在不知该如何写语句

求助.rar (29.5 KB, 下载次数: 6)

2024-8-11 18:06 上传

点击文件名下载附件

老师如有空，请帮忙看看，先谢谢了！

醉眼看尘世

是不是要这样？

1. Sub test()
   
2. Dim Arr, i&, j&, k&, x&, m&
   
3. Arr = Sheet1.[a2].Resize(Sheet1.[a1].CurrentRegion.Rows.Count - 1, 12)
   
4. ReDim Brr(1 To UBound(Arr, 1) * 3, 1 To 5)
   
5. x = 0
   
6. 
   
7. For i = 1 To UBound(Arr, 1)
   
8.     For j = 1 To UBound(Arr, 2) Step 4
   
9.         x = x + 1
   
10.         For k = 1 To 3
    
11.             Brr(x, k) = Arr(i, j + k - 1)
    
12.         Next k
    
13.         tmp = Arr(i, j + 3)
    
14.         If tmp = 0 Then
    
15.             If x < UBound(Arr, 1) Then
    
16.                 For m = x + 1 To UBound(Arr, 1)
    
17.                     If Arr(m, j + 3) = 1 Then
    
18.                         Brr(x, 4) = Arr(m, j)
    
19.                         Brr(x, 5) = Arr(m, j + 2)
    
20.                         Exit For
    
21.                     End If
    
22.                 Next m
    
23.             End If
    
24.         End If
    
25.     Next j
    
26. Next i
    
27. With Sheet1
    
28.     .Range("N:R").ClearContents
    
29.     .[n1:r1] = Array("CD", "D", "ZF", "CD", "ZF")
    
30.     .[n2].Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
31. End With
    
32. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, n&
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar, 2) / 4, 1 To 5)
   
    For j = 1 To UBound(ar, 2) Step 4
        n = n + 1
        For i = 1 To 3
            br(n, i) = ar(2, j - 1 + i)
        Next i
        If ar(2, j + 3) <> 1 Then
            For i = 2 To UBound(ar)
                If ar(i, j + 3) = 1 Then
                    br(n, 4) = ar(i, j)
                    br(n, 5) = ar(i, j + 2)
                    Exit For
                End If
            Next i
        End If
    Next j
   
    [T2].Resize(UBound(br), UBound(br, 2)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。

excel玉米

lhj323323

醉眼看尘世 发表于 2024-8-11 18:51
是不是要这样？

谢谢醉眼看尘世老师！

但生成的数据，应该只有三行