[已解决]execl箱单自动提取并列表出来

w2001pf

你发全表吧？如果不方便发到论坛上，你就给QQ号给我，我再看看吧？另外，程序略有修改。Option Explicit
Sub 箱单()
Dim rowshu, columnshu, arr, i, j, n, m, k
Dim d As New Dictionary
Sheets("大货清单").Select
rowshu = Range("A65536").End(xlUp).Row
columnshu = 51 'Range("dz1").End(xlToLeft).Column

arr = Sheets("大货清单").Range(Cells(2, 1), Cells(rowshu, columnshu))
Sheets("装箱单").Select
Range("a1:E" & rowshu).Delete
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   For i = 1 To UBound(arr)
        For j = 4 To UBound(arr, 2) Step 2
                If arr(i, j) <> "" Then
                    If d.Exists(arr(i, j)) = False Then
                        n = n + 1
                        d(arr(i, j)) = n
                    End If
                End If
        Next j
    Next i
'ReDim arr1(1 To UBound(arr), 1 To 5)
n = 0

For m = 0 To d.Count
n = n + 2

With Sheets("装箱单")
        .Cells(n - 1, 1) = "(" & m + 1 & "号箱)"
         Sheets("装箱单").Select
   .Range(.Cells(n - 1, 1), .Cells(n, 5)).Select
        Range(Cells(n - 1, 1), Cells(n, 5)).HorizontalAlignment = Excel.xlCenter
        .Cells(n - 1, 1).Font.Name = "宋体"
        .Cells(n - 1, 1).Font.Size = 14
        .Cells(n - 1, 1).Font.Bold = True
        .Range(.Cells(n - 1, 1), .Cells(n - 1, 5)).Merge
        
        .Range(.Cells(n - 1, 1), .Cells(n, 5)).Interior.ColorIndex = 2
        .Cells(n, 1) = "序号"
        .Cells(n, 2) = "货号"
        .Cells(n, 3) = "品名"
        .Cells(n, 4) = "条形码"
        .Cells(n, 5) = "数量"
  End With
           k = 0
For i = 1 To UBound(arr)
        For j = 4 To UBound(arr, 2) Step 2
                If arr(i, j) = m + 1 Then
                 
                 
                     k = k + 1

                With Sheets("装箱单")

                 .Cells(n + k, 5) = arr(i, j + 1)
                  .Cells(n + k, 1) = k
                  .Cells(n + k, 2) = arr(i, 1)
                 .Cells(n + k, 3) = arr(i, 2)
                 .Cells(n + k, 4) = arr(i, 3)
                End With
                End If
        Next j
        
    Next i
    With Sheets("装箱单")
    .Cells(n + k + 1, 4) = "合计"
    .Range(.Cells(n + k + 1, 4), .Cells(n + k + 1, 5)).Font.Bold = True
    .Range(.Cells(n + k + 1, 4), .Cells(n + k + 1, 5)).Font.ColorIndex = 5
   
   .Cells(n + k + 1, 5) = Application.WorksheetFunction.Sum(.Range(.Cells(n + 1, 5), .Cells(n + k, 5)))
   Sheets("装箱单").Select
   .Range(.Cells(n, 1), .Cells(n + k + 1, 5)).Select
   With Selection.Borders
         .LineStyle = xlContinuous
         .Weight = xlHairline
      
     End With
    Selection.BorderAround xlContinuous, xlMedium
    End With
    n = n + k + 3

Next m
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

xujinbobolic

w2001pf 发表于 2013-7-2 20:05
你发全表吧？如果不方便发到论坛上，你就给QQ号给我，我再看看吧？另外，程序略有修改。Option Explicit
S ...

谢谢，这个就正常了，可能是我的office版本的问题吧 我在win7的系统下用完全正常，再次感谢！！

lion_zjy

学习学习