——VBA—数组填充问题求助，辛苦帮忙看下了，先谢过！！

阿蒙森

——VBA—数组数据 填充（不要有空行），代码找不到原因，谢谢了undefinedundefined
Sub 提取报表数据()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim s, r, r1, r2 As Integer
Dim f, sh As Worksheet
Dim d As Object, i&, j&, k&
Dim arr, brr()
   ThisWorkbook.Sheets("完工").Cells.ClearContents
    f = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls;*.xlsx),*.xls;*.xlsx", Title:="选择Excel文件")
     Workbooks.Open Filename:=f, Password:="789123", writerespassword:="6b7b5b1b5b1b5"
        For Each sh In Sheets
            If sh.Name <> " " Then
                With sh
                    Set d = CreateObject("scripting.dictionary")
                      LastRow = sh.Range("b65536").End(xlUp).Row
                      LastCount = sh.Cells(4, Columns.Count).End(xlToLeft).Column
                     arr = sh.Range("a1:" & "y" & .Range("b200").End(xlUp).Row)
                     ReDim brr(1 To 10000, 1 To 10)
                   For i = 5 To UBound(arr)
                     s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 4)
                      If Not d.exists(s) Then
                             k = k + 1
                             d(s) = k
                           brr(k, 1) = Right(sh.Cells(3, 15), (Len(sh.Cells(3, 15)) - (InStr(sh.Cells(3, 15), "年"))))
                           brr(k, 2) = arr(i, 1) '订单号
                           brr(k, 3) = arr(i, 2) '型号
                           brr(k, 4) = arr(i, 6) '生产数
                           brr(k, 5) = arr(i, 4) '颜色
                           brr(k, 6) = Right(sh.Cells(3, 1), (Len(sh.Cells(3, 1)) - (InStr(sh.Cells(3, 1), "：")))) '作业员
                      Else
                           n = d(s)
                           brr(n, 4) = brr(n, 4) + arr(i, 6)
                      End If
                   Next
                End With
                LastRow1 = ThisWorkbook.Sheets("完工").Range("b65536").End(xlUp).Row + 1
                ThisWorkbook.Sheets("完工").Range("a" & LastRow1).Resize(k, UBound(brr, 2)) = brr
                Set d = Nothing
            End If
        Next
         ActiveWorkbook.Close
    ActiveSheet.Range("a:h").EntireColumn.AutoFit
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

abc123281

VBA跨表提取数组填充问题.rar (13.94 KB, 下载次数: 9)

2022-3-24 22:57 上传

点击文件名下载附件

阿蒙森

abc123281 发表于 2022-3-24 22:57

https://club.excelhome.net/thread-1621179-1-1.html
完美解决，十分感谢！！这个能帮我看下吗？我用循环感觉不理想，希望用数组实现，谢谢