自动填列并插入批注

ajgdm122

各位大神，请教如何把序时的收款金额自动填列到合同表收款金额并增加批注？后续继续收款的话就自动往后填列。

ykcbf1100

数据写入合同表后，源数据清除，避免重复写入。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.12
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("合同")
   
6.         .UsedRange.Offset(1).Clear
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         c = .Cells(r, 1).End(2).Column
   
9.         c = IIf(r = 1, c - 2, c)
   
10.         arr = .[a1].Resize(r, c)
    
11.         ReDim brr(1 To 1000, 1 To 20)
    
12.         If r > 1 Then
    
13.             For i = 2 To UBound(arr)
    
14.                 s = arr(i, 1)
    
15.                 d(s) = ""
    
16.             Next
    
17.         End If
    
18.     End With
    
19.     On Error Resume Next
    
20.     With Sheets("序时")
    
21.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
22.         arr = .[a1].Resize(r, 7)
    
23.     End With
    
24.     For i = 2 To UBound(arr)
    
25.         s = arr(i, 1)
    
26.         If s <> Empty Then
    
27.             If Not d.exists(s) Then
    
28.                 m = m + 1
    
29.                 brr(m, 1) = arr(i, 1)
    
30.                 brr(m, 2) = arr(i, 2)
    
31.                 brr(m, c + 1) = arr(i, 5)
    
32.                 d(s) = arr(i, 6)
    
33.             End If
    
34.         End If
    
35.     Next
    
36.     With Sheets("合同")
    
37.         r = .Cells(Rows.Count, 1).End(3).Row
    
38.         .Cells(r + 1, 1).Resize(m, c + 1) = brr
    
39.         .Cells(r + 1, 1).Resize(m, c + 1).Borders.LineStyle = 1
    
40.         For i = 2 To r + m
    
41.             s = .Cells(i, 1)
    
42.             .Cells(i, c + 1).ClearComments
    
43.             .Cells(i, c + 1).AddComment
    
44.             .Cells(i, c + 1).Comment.Text Text:=d(s)
    
45.         Next
    
46.     End With
    
47.     Sheets("序时").UsedRange.Offset(1) = ""
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, k&
   
    ar = Sheets(1).[A1].CurrentRegion.Value
    With [A1].CurrentRegion
        br = .Value
        .Columns("K").Offset(1).Clear
        For i = 1 To UBound(br)
            For k = 1 To UBound(ar)
                If ar(k, 1) = br(i, 1) Then
                    With .Cells(i, "K")
                        .Value = ar(k, 5)
                        .AddComment
                        .Comment.Text Text:=ar(i, 6)
                    End With
                    Exit For
                End If
            Next k
        Next i
    End With
   
    Beep
End Sub

gwjkkkkk

参与一下。。。

ajgdm122

gwjkkkkk 发表于 2024-3-12 19:19
Option Explicit
Sub TEST1()
    Dim ar, br, i&, k&

非常感谢，但是这种先清除再添加不适合，因为原本表里已经填了很多年的数据，不可以删除旧的，只能增加新的，我的想法是选中新增的收款记录，然后点一个按钮，就把选中的增加到合同表里，然后打个√表示完成。不知编程是否很麻烦，非常感谢抽空帮忙！！抱拳！

ajgdm122

ykcbf1100 发表于 2024-3-12 18:37
参与一下。。。

非常感谢，但是这种先清除再添加不适合，因为原本表里已经填了很多年的数据，不可以删除旧的，只能增加新的，我的想法是选中新增的收款记录，然后点一个按钮，就把选中的增加到合同表里，然后打个√表示完成。不知编程是否很麻烦，非常感谢抽空帮忙！！抱拳！

xunanming

'需求中没的明确合同表中的合同号是否提前填入的.所以代码是合同表中的合同号是按提前填写的,如果需要选择区域后填入,代码就需要更改.