单独提取提取数据是怎么写

5550381

ykcbf1100

代码已同步更新。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.10
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set sh = ThisWorkbook.Sheets("客户单月数据")
   
4.     kh = sh.[c3].Value
   
5.     fn = [{"今年","前年"}]
   
6.     For x = 1 To 2
   
7.         d.RemoveAll
   
8.         With Sheets(fn(x))
   
9.             r = .Cells(Rows.Count, 1).End(3).Row
   
10.             arr = .[a1].Resize(r, 9)
    
11.             For i = 3 To UBound(arr)
    
12.                 s = Month(arr(i, 2))
    
13.                 d(s) = d(s) + arr(i, 8)
    
14.             Next
    
15.             With sh
    
16.                 For k = 6 To 17
    
17.                     s = Val(.Cells(k, 2 + (x - 1) * 3))
    
18.                     .Cells(k, 3 + (x - 1) * 3) = d(s)
    
19.                 Next
    
20.                 ActiveWindow.DisplayZeros = False
    
21.             End With
    
22.         End With
    
23.     Next
    
24. End Sub
    
25. 
    

复制代码

5550381

ykcbf1100 发表于 2024-6-10 15:40
附件供参考。。。

请问下（客户名:         ）这个更换名字后，无法更新数据是什么情况

quqiyuan

参与一下，供参考

quqiyuan

代码如下：
Sub test()
Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    For Each sht In Sheets([{"今年","前年"}])
        With sht
            n = 0
            r = .UsedRange.Rows.Count
            arr = .Range("a3:i" & r)
            ReDim brr(1 To UBound(arr), 1 To 2)
            For i = 1 To UBound(arr)
                If arr(i, 1) = Sheets("客户单月数据").[c3] Then
                    m = Month(CDate(arr(i, 2)))
                    s = arr(i, 1) & "|" & m
                    If Not d.exists(s) Then
                        n = n + 1
                        d(s) = n
                        brr(n, 1) = m
                        brr(n, 2) = arr(i, 8)
                    Else
                        x = d(s)
                        brr(x, 2) = brr(x, 2) + arr(i, 8)
                    End If
                 End If
            Next
            With Sheets("客户单月数据")
                If sht.Name = "今年" Then
                    Set Rng = .Range("b6:c17")
                Else
                    Set Rng = .Range("b6:c17").Offset(, 3)
                End If
                Rng.Offset(, 1).ClearContents
                For i = 1 To n
                    Rng.Cells(brr(i, 1), 2) = brr(i, 2)
                Next
            End With
        d.RemoveAll
        End With
    Next
    Beep
Application.ScreenUpdating = True
End Sub

quqiyuan

更换名字后可以自动刷新的话，需要使用change事件，供参考

ykcbf1100

5550381 发表于 2024-6-10 15:57
请问下（客户名:         ）这个更换名字后，无法更新数据是什么情况

改好了，少加了个判断

EHGOOD

参与一下，选择客户名后事件触发运行，省一步点按钮。

Qs18

Sub 今年()
Dim arr, brr
a = Sheet7.[b6:c17]
arr = Sheet3.Range("a2").CurrentRegion.Value
mc = Sheet7.Range("c3").Value
For i = 1 To UBound(a)
    For j = 3 To UBound(arr)
        yu = Month(CDate(arr(j, 2))) & "月份"
        If mc = arr(j, 1) And a(i, 1) = yu Then
            a(i, 2) = a(i, 2) + arr(j, 8)
        End If
    Next j
Next
Sheet7.Range("b6").Resize(12, 2) = a
Call 前年
End Sub
Sub 前年()
Dim arr, brr
a = Sheet7.[e6:f17]
arr = Sheet4.Range("a2").CurrentRegion.Value
mc = Sheet7.Range("c3").Value
For i = 1 To UBound(a)
    For j = 3 To UBound(arr)
        yu = Month(CDate(arr(j, 2))) & "月份"
        If mc = arr(j, 1) And a(i, 1) = yu Then
            a(i, 2) = a(i, 2) + arr(j, 8)
        End If
    Next j
Next
Sheet7.Range("e6").Resize(12, 2) = a
End Sub