|
本帖最后由 flybeyondsky 于 2014-1-10 16:27 编辑
1.对D列筛选非空值。然后整表复制到SHEET2.
2.对F列筛选非空值。然后整个表接着复制到刚才的内容下面。
3.H列,J列,等等
也就是对配货入那一列进行单独的筛选非空值,然后依次复制到SHEET2.
自己尝试写代码 ,一直有问题。望高手指点。
详见附件。- Sub 重复筛选汇总()
- Dim arr, i&, j&, m&, c%, r&
- arr = [a1].CurrentRegion
- With Sheets("Sheet2")
- If WorksheetFunction.CountA(.UsedRange) = 0 Then
- m = 2
- r = 1
- Else
- r = .Range("a" & Rows.Count).End(xlUp).Row + 1
- End If
- For c = 4 To UBound(arr, 2) Step 2
- For i = 3 To UBound(arr)
- If Len(arr(i, c)) Then
- m = m + 1
- For j = 1 To UBound(arr, 2)
- arr(m, j) = arr(i, j)
- Next
- End If
- Next
- Next
- .Cells(r, 1).Resize(m, j + 1) = arr
- .Activate
- End With
- End Sub
复制代码
出错原因:原来的输出数组arr的行数,远远不够记录符合条件的数据数量。
解决办法:重新声明一个行数足够的数组brr。
Sub 重复筛选汇总()
Dim arr, i&, j&, m&, c%, r&
arr = Sheet1.[a1].CurrentRegion
With Sheets("Sheet2")
'1)确定输出位置
If .[a3] = "" Then
m = 2
r = 1
Else
r = .Range("a" & Rows.Count).End(xlUp).Row + 1
End If
'2)生成输出数组brr
ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To UBound(arr, 2))
For c = 4 To UBound(arr, 2) Step 2
For i = 3 To UBound(arr)
If Len(arr(i, c)) Then
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next
End If
Next
Next
'3) 输出
.Cells(r, 1).Resize(m, j - 1) = brr
.Activate
End With
End Sub
BOOK1b.rar
(784.44 KB, 下载次数: 21)
|
|