遍历文件夹求同批号的总数量

tiantao186

文件夹中有多个表格，格式相同，求同批号产品的总数量

3190496160

Sub test()
Application.ScreenUpdating = False
  Dim r%, i%, c%, j%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  ReDim arr(1 To 10000, 1 To 3)
  lj = ThisWorkbook.Path & "\"
  f = Dir(lj & "*.xls*")
  Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(lj & f, 0)
        With wb.Worksheets(1)
          c = .Cells(1, .Columns.Count).End(xlToLeft).Column
          x = .UsedRange.Rows.Count
          ar = .Range("a1").Resize(x, c)
        End With
        wb.Close False
        For i = 2 To UBound(ar)
            For j = 14 To UBound(ar, 2)
                If InStr(ar(1, j), "批号") > 0 Then
                    If Trim(ar(i, j)) <> "" Then
                        'If Len(Trim(ar(i, j))) = 10 Then
                            t = d(Trim(ar(i, j)))
                            If t = "" Then
                                k = k + 1
                                d(Trim(ar(i, j))) = k
                                t = k
                                arr(k, 1) = ar(i, j)
                                arr(k, 2) = ar(i, j - 1)
                            End If
                            arr(t, 3) = arr(t, 3) + ar(i, j + 1)
                        'End If
                    End If
                End If
            Next j
        Next i
    End If
    f = Dir
    Loop
    'If k = "" Then End
    With ActiveSheet
        .[a1].CurrentRegion.Offset(1) = Empty
        .[a2].Resize(k, 3) = arr
    End With
Application.ScreenUpdating = True
End Sub

3190496160

3190496160

求助表.rar (54.48 KB, 下载次数: 13)

2023-2-21 18:26 上传

点击文件名下载附件

tiantao186

3190496160 发表于 2023-2-21 18:27

谢谢老师，很好用