周查询SHEET1数据，反黄色數據到sheet2

cmo9020

123.rar (726.63 KB, 下载次数: 3)

2022-12-25 17:02 上传

点击文件名下载附件

导师们好~~~~周末假日快乐请教导师们问题
周查询SHEET1数据，反黄色數據到sheet2
怎么修改这?谢谢各位导师

Sub 按鈕4388_Click()
Dim brr(1 To 100, 1 To 13), crr(1 To 100, 1 To 13)
With Sheet1
    r1 = .Cells(.Rows.Count, 1).End(3).Row
    arr1 = .Range("C4:AB" & r1)
End With
td = [D1]
For i = 1 To UBound(arr1)
If arr1(i, 4) = td Then
k = k + 1
brr(k, 1) = arr1(i, 1)
For j = 2 To 13
brr(k, j) = arr1(i, j + 1)
Next
End If
Next
If k <> 0 Then
Range("A3:M25").ClearContents
[A3].Resize(k, 13) = brr
Else
MsgBox "NO Data"
End If

End Sub

shiruiqiang

数组arr1=sheets(1).range("c4:ab"&r1),"WK"在“d”列，那应该循环是从arr1(i,2)=td才是吧, for i 要从1开始

cmo9020

shiruiqiang 发表于 2022-12-25 20:16
数组arr1=sheets(1).range("c4:ab"&r1),"WK"在“d”列，那应该循环是从arr1(i,2)=td才是吧, for i 要从1开 ...

谢谢导师解答...目前机器人给我的答案是这样,问题己解决
谢谢导师~



Sub Button4388_Click()
    Dim arr1 As Variant
    Dim brr(1 To 100, 1 To 12) As Variant ' Modified array to store 12 columns
    Dim r1 As Long, td As Date, k As Long
   
    With Sheet1
        r1 = .Cells(.Rows.Count, 3).End(3).Row ' Get the last row of column C
        arr1 = .Range("A3:AC" & r1) ' Read all columns from A3 to AC of Sheet1
        
        td = [D1] ' Get the value in D1
        
        ' Clear the contents of A3:M25 in Sheet2
        Sheet2.Range("A3:M25").ClearContents
    End With
   
    For i = 1 To UBound(arr1)
        If arr1(i, 3) = td Then ' If the date in column C matches the value in D1
            k = k + 1
            brr(k, 1) = arr1(i, 3) ' C column
            brr(k, 2) = arr1(i, 4) ' D column
            brr(k, 3) = arr1(i, 6) ' F column
            brr(k, 4) = arr1(i, 7) ' G column
            brr(k, 5) = arr1(i, 8) ' H column
            brr(k, 6) = arr1(i, 9) ' I column
            brr(k, 7) = arr1(i, 10) ' J column
            brr(k, 8) = arr1(i, 11) ' K column
            brr(k, 9) = arr1(i, 16) ' P column
            brr(k, 10) = arr1(i, 24) ' X column
            brr(k, 11) = arr1(i, 26) ' Z column
            brr(k, 12) = arr1(i, 27) ' AA column
        End If
    Next
   
    If k <> 0 Then
        ' Copy the data from brr to A3:L in Sheet2
        Sheet2.Range("A3").Resize(k, 12) = brr
    Else
        MsgBox "NO Data"
    End If
End Sub