|
|
本帖最后由 yiyiyicz 于 2013-1-30 17:30 编辑
怎么又快又准获得BOM，见
http://club.excelhome.net/forum.php?mod=viewthread&tid=737976&page=4&extra=#pid6695319
excelhome中有数以百计帖子涉及BOM
BOM是制造业信息化中肯定用到的东西，BOM理论又是信息化的基础理论，这许多的帖子让人眼花缭乱。本人选择了一些自己关心的帖子汇总如下
1，《把父子关系记录转为树形结构》
http://club.excelhome.net/viewthread.php?tid=142003&highlight=BOM
树状结构的表，原始数据往往只有父阶子阶。程序的目的是“显示任一阶的树状结构”
第一个例子中：在sheet1中。不太容易看出父子关系。在sheet3中，能看出父子关系的大概模样。需要耐心
例子中还有有用数组、find方法的
【第一个例子】
Private Sub CommandButton1_Click()
Dim TempRag As Range
Dim mycell, currentCell, nextCell As Range
Dim TempMsgBox As VbMsgBoxResult
Dim TempStr As String
Dim I, J, K, M, N, temp, finalrow, finalcolumn As Integer
Sheet2.Activate
Sheet2.Cells.ClearContents '初始化SHEET2
Sheet2.Cells.NumberFormatLocal = "@" '单元格格式设为文字?
Sheet1.Activate
Set TempRag = Sheet1.Application.Selection '选择要查询的上阶
If (TempRag.Column <> 1 Or Trim(TempRag.Value) = "") Then
TempMsgBox = MsgBox("?请选择父阶", vbOKOnly, "错误选择")
End
End If
finalrow = Range("A65536").End(xlUp).Row '得到行数
Sheet2.Cells(1, 1) = TempRag.Value '把要找的父阶放在第一个位置
I = 1 '初始行
J = 1 '初始列?
N = 2 '每一行的下阶个数,初始值为2是为了第一行能跑
Do While (N > 1) '如果上一列都没有下阶,说明已经展到底
K = 1 '初始写到SHEET2的行
N = 1 '每一行的下阶个数
Do While (Sheet2.Cells(I, J) <> "") '遍历每一列的非空值
M = 1 '每一格的下阶个数
For Each mycell In Sheet1.Range("A1:A" & finalrow) '在SHEET1的第一列寻找下阶
If (mycell.Value = Mid(Sheet2.Cells(I, J), 4 * (J - 1) + 1, 4)) Then '由于单元格的值是上下阶合并的,所以要取非空的最后四格
Sheet2.Cells(K, J + 1) = Sheet2.Cells(I, J) & mycell.Offset(, 1).Value '把上阶和下阶合并
K = K + 1 '行加一
M = M + 1 '每一格的下阶个数
N = N + 1 '每一行的下阶个数
End If
Next
If M = 1 Then
Sheet2.Cells(K, J + 1) = Sheet2.Cells(I, J) '没有下阶的也要写到新的一行去
K = K + 1
End If
I = I + 1 '行加一??
Loop
J = J + 1 '列加一
I = 1
Loop
Sheet3.Activate
Sheet3.Cells.ClearContents
Sheet3.Cells.NumberFormatLocal = "@"
Sheet2.Activate
finalrow = Range("A65536").End(xlUp).Row
K = 1
If Sheet2.Range("B1").Value <> "" Then
For Each mycell In Sheet2.Range("A1:A" & finalrow).Offset(, J - 2)
For I = 1 To Len(mycell.Value) / 4
Sheet3.Cells(K, I) = Mid(mycell.Value, 4 * (I - 1) + 1, 4)
Next
K = K + 1
Next
End If '把SHEET2的最后一列的每一行按四位一分写到SHEET3
Sheet3.Activate
finalcolumn = Cells(1, 255).End(xlToLeft).Column '得到列数
For I = 1 To finalcolumn
Set currentCell = Sheet3.Cells(1, I)
Set nextCell = currentCell.Offset(1, 0)
TempStr = Sheet3.Cells(1, I).Value
Do While Not IsEmpty(nextCell)
If nextCell.Value = TempStr Then
nextCell.ClearContents
Else
TempStr = nextCell.Value
End If
Set currentCell = nextCell
Set nextCell = currentCell.Offset(1, 0)
Loop
Next '把SHEET3每一列有重复的值放空????
End Sub
[ 本帖最后由 yiyiyicz 于 2011-7-4 23:42 编辑 ]
|
评分
-
5
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-7-4 16:03
楼主