求助

ab1556

设计vba代码将同一提单项下的出口金额汇总输出

taller

1. Sub a2()
   
2.     Dim sj(1 To 7, 1 To 3)
   
3.     r = -7: c = 7
   
4.     With Sheets("明细")
   
5.         arr = .Range("h02:n" & .Range("j50").End(xlUp).Row)
   
6.         wb = .Cells(1, 13) & "："
   
7.         For i = 1 To 7
   
8.             sj(i, 1) = .Cells(1, i + 7)
   
9.         Next i
   
10.     End With
    
11.     Dim d: Set d = CreateObject("scripting.dictionary")
    
12.     Dim drow: Set drow = CreateObject("scripting.dictionary")
    
13.     For i = 1 To UBound(arr)
    
14.         sKey = arr(i, 3)
    
15.         If d.exists(sKey) Then
    
16.             d(sKey) = d(sKey) + arr(i, 6)
    
17.         Else
    
18.             d(sKey) = arr(i, 6)
    
19.             drow(sKey) = i
    
20.         End If
    
21.     Next
    
22.     iCnt = 0
    
23.     For Each sKey In d.Keys
    
24.         i = drow(sKey)
    
25.         iCnt = iCnt + 1
    
26.         If iCnt Mod 3 = 1 Then
    
27.             r = r + 8
    
28.             Cells(r, 1).Resize(7, 8).Borders.LineStyle = xlContinuous
    
29.             Cells(r, 1).Resize(7, 8).HorizontalAlignment = xlCenter
    
30.             Cells(r + 5, 1).Resize(1, 8).NumberFormatLocal = "#,##0.00_ "
    
31.             Cells(r + 6, 1).Resize(1, 8).NumberFormatLocal = "#,##0.0000"
    
32.         End If
    
33.         c = c + 3
    
34.         If c > 7 Then
    
35.             c = 1
    
36.         End If
    
37.         For j = 1 To 7
    
38.             sj(j, 2) = arr(i, j)
    
39.             If j = 6 Then sj(j, 2) = d(sKey)
    
40.         Next j
    
41.         If sj(7, 2) < 10 Then
    
42.             sj(6, 1) = wb & "JPY"
    
43.         Else
    
44.             sj(6, 1) = wb & "USD"
    
45.         End If
    
46.         Cells(r, c).Resize(7, 2) = sj
    
47.     Next
    
48. End Sub

复制代码

taller

ab1556

谢谢taller大神,成功了

凌空一羽

ab1556

"出口金额：JPY"; 这里能不能加个判断,如果汇率大于100,就是"出口金额：USD",否则"出口金额：JPY";

taller

ab1556 发表于 2025-3-24 13:47
"出口金额：JPY"; 这里能不能加个判断,如果汇率大于100,就是"出口金额：USD",否则"出口金额：JPY";

当然可以，将类似于你的代码 If sj(7, 2) < 10 Then ，再增加一个判断，修改对应的列就可以了

ab1556

Sub lkyy1()
    Dim ws As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim uniqueValues As Object
    Dim value As Variant
    Dim n As Integer
    Dim column As Integer
    Dim cell As Range
    Dim filteredData As Range
    Dim rng As Range
   
    ' 设置"明细"工作表
    Set ws = ThisWorkbook.Sheets("明细")
   
    ' 设置"生成表"工作表（用于输出结果）
    Set wsResult = ThisWorkbook.Sheets("生成表")
   
    ' 获取A列最后有数据的行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    ' 定义数据范围：A2到Q列的最后一个有数据的行
    Set dataRange = ws.Range("A2:Q" & lastRow)
   
    ' 创建字典对象用于存储唯一值
    Set uniqueValues = CreateObject("Scripting.Dictionary")
   
    ' 遍历第10列(J列)的所有单元格，提取唯一值
    For Each cell In dataRange.Columns(10).Cells
        If Not IsEmpty(cell.value) Then
            uniqueValues(cell.value) = 1  ' 将提运单号作为键存入字典
        End If
    Next cell
   
    ' 初始化计数器
    n = 0
   
    ' 遍历每个唯一的提运单号
    For Each value In uniqueValues.Keys
        n = n + 1
        ' 计算输出列位置（每3列一组数据）
        column = n * 3 - 2  ' 第一组数据从第1列开始，第二组从第4列开始...
        
        ' 在"生成表"中写入固定标题
        wsResult.Cells(2, column).value = "出口：合同号："
        wsResult.Cells(3, column).value = "提运单号："
        wsResult.Cells(4, column).value = "装船口岸："
        wsResult.Cells(5, column).value = "目的地："
        wsResult.Cells(6, column).value = "出口金额："
        wsResult.Cells(7, column).value = "汇率："
        
        ' 在数据范围中查找当前提运单号
        Set rng = dataRange.Columns(10)  ' 第10列(J列)
        Set filteredData = Nothing
        
        ' 使用Find方法查找（添加错误处理）
        On Error Resume Next
        Set filteredData = rng.Find(What:=value, LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0
        
        ' 如果找到匹配项
        If Not filteredData Is Nothing Then
            Dim firstAddress As String
            firstAddress = filteredData.Address  ' 记录第一个找到的单元格地址
            Dim sumAmount As Double
            sumAmount = 0  ' 初始化金额合计
            Dim currencyType As String
            Dim exchangeRate As Double
            
            ' 循环查找所有匹配的行
            Do
                ' 累加出口金额（第13列/M列）
                sumAmount = sumAmount + filteredData.Offset(0, 3).value
               
                ' 获取汇率（第14列/N列）
                exchangeRate = filteredData.Offset(0, 4).value
               
                ' 根据汇率确定货币类型
                If exchangeRate < 10 Then
                    currencyType = "JPY"  ' 日元
                Else
                    currencyType = "USD"  ' 美元
                End If
               
                ' 如果是第一次找到，记录基本信息
                If filteredData.Address = firstAddress Then
                    ' 写入合同号（第9列/I列）
                    wsResult.Cells(2, column + 1).value = filteredData.Offset(0, -1).value
                    ' 写入提运单号
                    wsResult.Cells(3, column + 1).value = value
                    ' 写入装船口岸（第11列/K列）
                    wsResult.Cells(4, column + 1).value = filteredData.Offset(0, 1).value
                    ' 写入目的地（第12列/L列）
                    wsResult.Cells(5, column + 1).value = filteredData.Offset(0, 2).value
                End If
               
                ' 查找下一个匹配项
                Set filteredData = rng.FindNext(filteredData)
            Loop While Not filteredData Is Nothing And filteredData.Address <> firstAddress
            
            ' 写入汇总数据
            wsResult.Cells(6, column).value = "出口金额：" & currencyType
            wsResult.Cells(6, column + 1).value = sumAmount
            wsResult.Cells(7, column + 1).value = exchangeRate
        End If
    Next value
End Sub

ab1556

这是改进后的方法

ab1556

大神参考
Sub lkyy1()
    Dim ws As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim uniqueValues As Object
    Dim value As Variant
    Dim n As Integer
    Dim column As Integer
    Dim cell As Range
    Dim filteredData As Range
    Dim rng As Range
   
    ' 设置"明细"工作表
    Set ws = ThisWorkbook.Sheets("明细")
   
    ' 设置"生成表"工作表（用于输出结果）
    Set wsResult = ThisWorkbook.Sheets("生成表")
   
    ' 获取A列最后有数据的行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    ' 定义数据范围：A2到Q列的最后一个有数据的行
    Set dataRange = ws.Range("A2:Q" & lastRow)
   
    ' 创建字典对象用于存储唯一值
    Set uniqueValues = CreateObject("Scripting.Dictionary")
   
    ' 遍历第10列(J列)的所有单元格，提取唯一值
    For Each cell In dataRange.Columns(10).Cells
        If Not IsEmpty(cell.value) Then
            uniqueValues(cell.value) = 1  ' 将提运单号作为键存入字典
        End If
    Next cell
   
    ' 初始化计数器
    n = 0
   
    ' 遍历每个唯一的提运单号
    For Each value In uniqueValues.Keys
        n = n + 1
        ' 计算输出列位置（每3列一组数据）
        column = n * 3 - 2  ' 第一组数据从第1列开始，第二组从第4列开始...
        
        ' 在"生成表"中写入固定标题
        wsResult.Cells(2, column).value = "出口：合同号："
        wsResult.Cells(3, column).value = "提运单号："
        wsResult.Cells(4, column).value = "装船口岸："
        wsResult.Cells(5, column).value = "目的地："
        wsResult.Cells(6, column).value = "出口金额："
        wsResult.Cells(7, column).value = "汇率："
        
        ' 在数据范围中查找当前提运单号
        Set rng = dataRange.Columns(10)  ' 第10列(J列)
        Set filteredData = Nothing
        
        ' 使用Find方法查找（添加错误处理）
        On Error Resume Next
        Set filteredData = rng.Find(What:=value, LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0
        
        ' 如果找到匹配项
        If Not filteredData Is Nothing Then
            Dim firstAddress As String
            firstAddress = filteredData.Address  ' 记录第一个找到的单元格地址
            Dim sumAmount As Double
            sumAmount = 0  ' 初始化金额合计
            Dim currencyType As String
            Dim exchangeRate As Double
            
            ' 循环查找所有匹配的行
            Do
                ' 累加出口金额（第13列/M列）
                sumAmount = sumAmount + filteredData.Offset(0, 3).value
               
                ' 获取汇率（第14列/N列）
                exchangeRate = filteredData.Offset(0, 4).value
               
                ' 根据汇率确定货币类型
                If exchangeRate < 10 Then
                    currencyType = "JPY"  ' 日元
                Else
                    currencyType = "USD"  ' 美元
                End If
               
                ' 如果是第一次找到，记录基本信息
                If filteredData.Address = firstAddress Then
                    ' 写入合同号（第9列/I列）
                    wsResult.Cells(2, column + 1).value = filteredData.Offset(0, -1).value
                    ' 写入提运单号
                    wsResult.Cells(3, column + 1).value = value
                    ' 写入装船口岸（第11列/K列）
                    wsResult.Cells(4, column + 1).value = filteredData.Offset(0, 1).value
                    ' 写入目的地（第12列/L列）
                    wsResult.Cells(5, column + 1).value = filteredData.Offset(0, 2).value
                End If
               
                ' 查找下一个匹配项
                Set filteredData = rng.FindNext(filteredData)
            Loop While Not filteredData Is Nothing And filteredData.Address <> firstAddress
            
            ' 写入汇总数据
            wsResult.Cells(6, column).value = "出口金额：" & currencyType
            wsResult.Cells(6, column + 1).value = sumAmount
            wsResult.Cells(7, column + 1).value = exchangeRate
        End If
    Next value
End Sub