求助统计

q360043839

怎么通过vba一键提取每张表对应的规格数量填写进本月实际销售。规格如果出现不一样的表现词应该怎么体现，比如规格10mg*7片=10毫克*7片，数量所在列是，数量=流向数量，而且每一张表的规格和数量都不在一个相同一个列

mmwwdd

写了半天，一看有点问题，就是以为你表中的数据是填好的呢
Sub tees()
Dim Mypath$, Myname$
Dim wb As Workbook
Dim ws As Worksheet
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("Sheet1")
Set d = CreateObject("scripting.dictionary")
Mypath = ThisWorkbook.Path & "\本月实际销售\"
Myname = Dir(Mypath & "*.xls*")
Do While Myname <> ""
    Set wb = GetObject(Mypath & Myname)
      With wb.Sheets(1)
         arr = .Range("A1").CurrentRegion
         For j = 1 To UBound(arr, 2)
           Select Case arr(1, j)
                  Case Is = "销售人"
                     xsr = j
                  Case Is = "客户名称"
                     khmc = j
                  Case Is = "流向数量", "数量"
                     lx = j
                  Case Is = "规格"
                     gg = j
            End Select
         Next
         For i = 2 To UBound(arr)
           If InStr(arr(i, gg), "毫克") Then
              arr(i, gg) = Replace(arr(i, gg), "毫克", "mg")
           End If
           If InStr(arr(i, gg), "s") Then
               arr(i, gg) = Replace(arr(i, gg), "s", "片")
           End If
           If Not d.exists(arr(i, xsr)) Then
              Set d(arr(i, xsr)) = CreateObject("scripting.dictionary")
           End If
           If Not d(arr(i, xsr)).exists(arr(i, khmc)) Then
              Set d(arr(i, xsr))(arr(i, khmc)) = CreateObject("scripting.dictionary")
           End If
               d(arr(i, xsr))(arr(i, khmc))(arr(i, gg)) = d(arr(i, xsr))(arr(i, khmc))(arr(i, gg)) + arr(i, lx)
         Next
             For Each aa In d.keys
                With sht
                   For i = 5 To 13
                      If .Cells(i, 2) = aa Then
                          For Each bb In d(aa).keys
                               If bb = .Cells(i, 3) Then
                                  For Each cc In d(aa)(bb).keys
                                       For k = 4 To 19
                                          If .Cells(3, k).MergeArea.Cells(1, 1).Address = .Cells(3, k).Address Then
                                              If InStr(.Cells(3, k).Value, cc) Then
                                                   .Cells(i, k + 2) = d(aa)(bb)(cc)
                                              End If
                                          End If
                                       Next
                                  Next
                                End If
                           Next
                        End If
                    Next
                 End With
             Next
             d.RemoveAll
            wb.Close False
     End With
Myname = Dir
Loop
End Sub

qdtzq

感觉用sql比较好

盼盼198310

..............

grf1973

有的表（如客户6）连销售人都没有，怎么统计？另外统计表中ABC列是已知条件吗？还是自由提取后更新的？

q360043839

盼盼198310 发表于 2023-5-22 11:10
..............

Sub FindSpecsAndSumQuantities()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") '假设在Sheet1中进行操作
   
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row '找到最后一行
   
    Dim specsCol As Long, quantitiesCol As Long
    specsCol = 0 '规格所在列
    quantitiesCol = 0 '数量所在列
   
    Dim i As Long, j As Long
    For i = 1 To lastRow
        For j = 1 To ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column
            If ws.Cells(i, j).Value = "规格" Then '找到规格所在列
                specsCol = j
            ElseIf ws.Cells(i, j).Value = "数量" Then '找到数量所在列
                quantitiesCol = j
            End If
        Next j
        If specsCol > 0 And quantitiesCol > 0 Then Exit For '找到后退出循环
    Next i
   
    If specsCol = 0 Or quantitiesCol = 0 Then
        MsgBox "未找到规格或数量所在列"
        Exit Sub
    End If
   
    Dim specSums As Object '用于存储每个规格下面的值之和
    Set specSums = CreateObject("Scripting.Dictionary")
   
    For i = 2 To lastRow '从第二行开始循环，第一行为表头
        Dim spec As String
        spec = ws.Cells(i, specsCol).Value '获取规格
        
        Dim quantity As Double
        quantity = ws.Cells(i, quantitiesCol).Value '获取数量
        
        If Not specSums.Exists(spec) Then
            specSums.Add spec, quantity '如果该规格第一次出现，直接添加数量
        Else
            specSums(spec) = specSums(spec) + quantity '否则将数量累加到之前的值之上
        End If
    Next i
   
    '将结果输出到新的Sheet2上
    Dim resultSheet As Worksheet
    Set resultSheet = ThisWorkbook.Worksheets.Add(after:=ws) '在当前ActiveSheet后新增一个Sheet
    resultSheet.Name = "结果"
   
    resultSheet.Cells(1, 1).Value = "规格"
    resultSheet.Cells(1, 2).Value = "数量"
   
    Dim rowNum As Long
    rowNum = 2
    Dim key As Variant
    For Each key In specSums.Keys '循环输出结果
        resultSheet.Cells(rowNum, 1).Value = key
        resultSheet.Cells(rowNum, 2).Value = specSums(key)
        rowNum = rowNum + 1
    Next key
End Sub