依据条件判断提取数据到分表

SCWYZJ

求助:我用VBA代码实现，依据条件判断提取数据到分表中，且部份调换位置存放（详见附件）并补充，指定"采购类型"为【采购入库】。烦请大神老师有空帮忙看看如何写，谢谢

lsc900707

1. Sub test()
   
2.     With Sheets("采购")
   
3.         arr = .[c4].CurrentRegion
   
4.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.         For i = 2 To UBound(arr)
   
6.             If InStr(arr(i, 1), "总仓库") > 0 And Len(arr(i, 11)) <> 0 And Len(arr(i, 12)) <> 0 Then
   
7.                 m = m + 1
   
8.                 brr(m, 1) = "采购入库"
   
9.                 For j = 2 To UBound(arr, 2)
   
10.                     brr(m, j) = arr(i, j)
    
11.                  Next
    
12.             End If
    
13.         Next
    
14.     End With
    
15.     With Sheets("总仓")
    
16.          r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
17.         .Cells(r + 1, 3).Resize(m, 13) = brr
    
18.     End With
    
19. End Sub

复制代码

lsc900707

代码审核中，先参考附件：

feilanga

...........................

feilanga

1. Sub Button1_Click()
   
2.     arr = Sheet1.Range("c1:o" & Sheet1.Cells(Rows.Count, "D").End(xlUp).Row) '数据源装入数组
   
3.     Dim brr()
   
4.     For i = 5 To UBound(arr)
   
5.         采购部门 = arr(i, 1)
   
6.         到货日期 = arr(i, 11)
   
7.         部门签收 = arr(i, 12)
   
8.         If 采购部门 = "总仓库" Then
   
9.             If 到货日期 <> "" And 部门签收 <> "" Then
   
10.                 b = b + 1
    
11.                 ReDim Preserve brr(1 To 13, 1 To b)
    
12.                 brr(1, b) = "采购入库"
    
13.                 brr(11, b) = arr(i, 1)
    
14.                 brr(12, b) = arr(i, 12)
    
15.                 brr(13, b) = arr(i, 13)
    
16.                 For j = 2 To 10
    
17.                     brr(j, b) = arr(i, j)
    
18.                 Next
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     ReDim temp(1 To b, 1 To 13)
    
23.     For i = 1 To b
    
24.         For j = 1 To 13
    
25.             temp(i, j) = brr(j, i)
    
26.         Next
    
27.     Next
    
28.      Sheet2.Range("C5:O" & Rows.Count).ClearContents
    
29.     Sheet2.Range("c5").Resize(UBound(temp), 13) = temp
    
30.     Sheet2.Activate
    
31. End Sub

复制代码

Qs18

Sub qs() '2024/7/3
    Dim arr, brr, i
    arr = Sheet1.Range("c4").CurrentRegion.Value
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If arr(i, 1) = "总仓库" And arr(i, 11) <> Empty And arr(i, 12) <> Empty Then
            m = m + 1
            For j = 1 To UBound(brr, 2)
                brr(m, j) = arr(i, j)
            Next
            brr(m, 1) = "采购入库": brr(m, 2) = arr(i, 11): brr(m, 11) = arr(i, 1)
        End If
    Next
    With Sheet2
        rw = .Cells(Rows.Count, "c").End(xlUp).Row + 1
        .Range("c" & rw).Resize(m, UBound(brr, 2)) = brr
        With .Range("C4").CurrentRegion
            .Borders.LineStyle = 1
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
End Sub

Qs18

试试...........

Qs18

试试..........

SCWYZJ

谢谢老师，我自己稍加改动就好了。

7993708

lsc900707 发表于 2024-7-3 21:23
代码审核中，先参考附件：

重复点击会一直累加进去