打钩自动复制填充数据

SCWYZJ

求助：vba如何实现打钩自动复制打钩行数据到其他表，取消时，自动从其他表清空粘贴的的数据（见附件），烦请老师们帮忙看看，谢谢

Qs18

1. Private Sub Worksheet_Activate()
   
2. Dim arr, i
   
3. arr = Sheet1.Range("b3").CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 6)
   
5. For i = 2 To UBound(arr)
   
6.     If arr(i, 12) = "√" Then
   
7.         m = m + 1
   
8.         For j = 3 To 5
   
9.             brr(m, j - 2) = arr(i, j)
   
10.         Next
    
11.             brr(m, 4) = arr(i, 8)
    
12.             brr(m, 5) = arr(i, 10)
    
13.             brr(m, 6) = arr(i, 11)
    
14.     End If
    
15. Next
    
16. Sheet2.Range("d4:i10000").ClearContents
    
17. Sheet2.Range("d4").Resize(m, 6) = brr
    
18. End Sub

复制代码

Qs18

试试。。。。。。。

Qs18

试试。。。。

饮冰e士

借楼请教大神，这种不连续的列，如何用一个公式来实现？

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("表一")
    Set sh = wb.Sheets("表二")
    Set d = CreateObject("scripting.dictionary")
    arr = sh.UsedRange
    brr = sht.UsedRange
    ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(2, j) <> Empty Then d(arr(2, j)) = j
        Next
    Next
    For i = 1 To UBound(brr, 2)
        If brr(1, i) = "是否" Then x = i: Exit For
    Next
    For i = 2 To UBound(brr)
        If brr(i, x) = "√" Then
            n = n + 1
            For j = 1 To UBound(brr, 2)
                If d.exists(brr(1, j)) Then
                    crr(n, d(brr(1, j))) = brr(i, j)
                End If
            Next
        End If
    Next
    sh.UsedRange.Offset(2).ClearContents
    sh.UsedRange.Cells(3, 1).Resize(n, UBound(crr, 2)) = crr
    Set d = Nothing
    Beep
    sh.Activate
End Sub

quqiyuan

饮冰e士 发表于 2024-9-28 18:50
借楼请教大神，这种不连续的列，如何用一个公式来实现？

M365有个choosecols函数
=CHOOSECOLS(FILTER(B3:M9,(M3:M9="√")+(M3:M9="是否")),3,4,5,8,10,11)

饮冰e士

quqiyuan 发表于 2024-9-28 19:50
M365有个choosecols函数
=CHOOSECOLS(FILTER(B3:M9,(M3:M9="√")+(M3:M9="是否")),3,4,5,8,10,11)

感谢，WPS也有这个公式。

SCWYZJ

Qs18 发表于 2024-9-28 18:49
试试。。。。

老师，你的代码符合我的要求。感谢。就是填充数据时不能按勾选顺序填充。如果能按勾选的先后顺序填充到表二（也按勾选顺序从上到下）就完美了。