相同发票号存在多个税目的，合并为一行，求大神相助！

draftroman

附件已添加，原版表中发票号对应的发票种类必然相同，但存在同一张发票多行税目数据的存在，现在需要添加按钮点击后使得目标表中发票号“一行只能对应一个”，同时存在多行税目的，在税目栏中以“/”进行分隔，发票金额保持前后一致。（税目可能是两个或更多个）

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("原版")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:h" & r)
   
9.         For i = 1 To UBound(arr)
   
10.             If Not d.exists(arr(i, 1)) Then
    
11.                 d(arr(i, 1)) = i
    
12.             Else
    
13.                 m = d(arr(i, 1))
    
14.                 If InStr(arr(m, 4), arr(i, 1)) = 0 Then
    
15.                     arr(m, 4) = arr(m, 4) & "/" & arr(i, 4)
    
16.                 End If
    
17.                 For j = 6 To 8
    
18.                     arr(m, j) = arr(m, j) + arr(i, j)
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.     End With
    
23.     ReDim brr(1 To d.Count, 1 To UBound(arr, 2))
    
24.     m = 0
    
25.     For Each aa In d.items
    
26.         m = m + 1
    
27.         For j = 1 To UBound(arr, 2)
    
28.             brr(m, j) = arr(aa, j)
    
29.         Next
    
30.     Next
    
31.     With Worksheets("目标")
    
32.         .UsedRange.Offset(1, 0).ClearContents
    
33.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
34.     End With
    
35. End Sub
    

复制代码

chxw68

详见附件。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.18
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("原版").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 2 To UBound(arr)
   
7.         s = CStr(arr(i, 1))
   
8.         If s <> Empty Then
   
9.             If Not d.exists(s) Then
   
10.                 m = m + 1
    
11.                 d(s) = m
    
12.                 For j = 1 To UBound(arr, 2)
    
13.                     brr(m, j) = arr(i, j)
    
14.                 Next
    
15.             Else
    
16.                 r = d(s)
    
17.                 If InStr(brr(r, 4), arr(i, 4)) = 0 Then
    
18.                     brr(r, 4) = brr(r, 4) & "/" & arr(i, 4)
    
19.                 End If
    
20.                 For j = 6 To UBound(arr, 2)
    
21.                     brr(r, j) = brr(r, j) + arr(i, j)
    
22.                 Next
    
23.             End If
    
24.         End If
    
25.     Next
    
26.     With Sheets("目标")
    
27.         .UsedRange.Offset(1).ClearContents
    
28.         .Columns(1).NumberFormatLocal = "@"
    
29.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, r&, dic As Object, iPosRow&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(1).[A1].CurrentRegion.Value
    r = 1
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            r = r + 1
            dic(ar(i, 1)) = r
            For j = 1 To UBound(ar, 2)
                ar(r, j) = ar(i, j)
            Next j
        Else
            iPosRow = dic(ar(i, 1))
            ar(iPosRow, 4) = ar(iPosRow, 4) & "/" & ar(i, 4)
            For j = 6 To UBound(ar, 2)
                ar(iPosRow, j) = ar(iPosRow, j) + ar(i, j)
            Next j
        End If
    Next i
   
    With Worksheets(2)
        .Cells.ClearContents
        .[A1].Resize(r, UBound(ar, 2)) = ar
        .Activate
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1").CurrentRegion.Value
   
5.    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 1)
   
8.         If Not dic.exists(s) Then
   
9.             m = m + 1
   
10.             dic(s) = m
    
11.             For j = 2 To UBound(arr, 2)
    
12.                 brr(m, j) = arr(i, j)
    
13.             
    
14.             Next
    
15.             brr(m, 1) = "'" & s
    
16.         Else
    
17.                 r = dic(s)
    
18.                 brr(r, 4) = brr(r, 4) & "/" & arr(i, 4)
    
19.                 For j = 6 To 8
    
20.                 brr(r, j) = brr(r, j) + arr(i, j)
    
21.                 Next
    
22.         End If
    
23.     Next
    
24. Sheet2.Range("a2").Resize(m, UBound(arr, 2)) = brr
    
25. Set dic = Nothing
    
26. End Sub

复制代码

Qs18

试试........

cnmlgb9998

PQ方案。。。。。。。。。。。。。。。。。



能自动刷 新