关于筛选后写值问题

sampsonpon

如图，修改下代码：

1. Sub CHECKTO()
   
2. 
   
3.     Application.ScreenUpdating = False
   
4.     '3/4改写：
   
5.     '如果"TO"工作表里K列有空白，那么
   
6.     '1、把K列是空白，所对应的的C列、D列不重复值写入到P2:Q列
   
7.     '================================================================================================================
   
8.     Dim s1$, s2$, s3$, s4$, s5$
   
9.     Dim dic, arr(), i&, iRow&, k, kk%
   
10.     With Sheet4
    
11.    
    
12.         iRow = .Range("A" & Rows.Count).End(3).Row
    
13.         kk = 0
    
14.         If iRow > 1 Then
    
15.             arr = .Range("A2:L" & iRow).Value
    
16.             Set dic = CreateObject("Scripting.Dictionary")
    
17.             For i = 1 To UBound(arr)
    
18.                 If Trim(arr(i, 11)) = "" Then
    
19.                     If Trim(arr(i, 3)) <> "" Then dic(CStr(arr(i, 3))) = ""
    
20.                 End If
    
21.             Next i
    
22.                
    
23.             iRow = .Range("P" & Rows.Count).End(3).Row
    
24.             If iRow > 1 Then .Range("P2:P" & iRow).ClearContents
    
25.                 If dic.Count > 0 Then
    
26.                     k = dic.keys
    
27.                     .Range("P2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(k)
    
28.                     
    
29. 
    
30.                 End If
    
31.             End If
    
32.     End With
    
33.    
    
34.     Application.ScreenUpdating = True
    
35. 
    
36. End Sub

复制代码

sampsonpon

有谁能赐个修改后代码呀

sxbjzjf110

不知理解的是否正确

lisongmei

没改，重新写了个，供参考
Option Explicit

Sub te()
Dim arr, brr(1 To 100, 1 To 2)
Dim dic, k, temp_arr
Dim sr$, i%, m%
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range([a1], [m63]).Value
For i = 2 To UBound(arr)
    If arr(i, 11) = "" Then
        sr = arr(i, 3) & "-" & arr(i, 4)
        dic(sr) = ""
    End If
Next
For Each k In dic.keys
    m = m + 1
    temp_arr = Split(k, "-")
    brr(m, 1) = temp_arr(0)
    brr(m, 2) = temp_arr(1)
Next
Range("P2").Resize(m, 2).Value = brr
End Sub

sampsonpon

sxbjzjf110 发表于 2024-3-15 09:49
不知理解的是否正确

还是有点小问题，我稍微改了下，想要的效果如图：

sampsonpon

lisongmei 发表于 2024-3-15 10:21
没改，重新写了个，供参考
Option Explicit

brr(1 To 100, 1 To 2)这里表示最多不能超过100行？
arr = Sheet1.Range([a1], [m63]).Value这里给限制区域了，能否加个按照A列或B列或C列的非空行来控制

sxbjzjf110

lisongmei

sampsonpon 发表于 2024-3-15 11:08
brr(1 To 100, 1 To 2)这里表示最多不能超过100行？
arr = Sheet1.Range([a1], [m63]).Value这里给限制 ...

我想着你上面的代码都能写出来 ，这里随便改写一下就行啊（比如100改为10000）。我为了方便，直接就取的固定区域。。。