|
|
这是我花了一个月的时间，边学边练编的，发上来给刚刚准备入门的菜鸟们看看。我在论坛里晃悠了一段时间，发现这里高手太多，自然编出来的VBA我们这些菜鸟们难以看得懂。希望我的这个简单程序能给象我一样的菜鸟们鼓鼓气，不要气馁，坚持就是胜利。
这个程序是我用一个个更小的程序慢慢编写、测试、查看帮助文件、上论坛求助得来的，程序编写的很罗嗦，让高手们发笑了。希望能有高手指正。
Sub 基本视图_MRP_04()
'
'
' 如果工作表为筛选状态，则取消筛选
'
'
Dim filter As Boolean
filter = ActiveWorkbook.Sheets("sheet1").AutoFilterMode
'MsgBox filter
If filter = True Then
ActiveWorkbook.Sheets("sheet1").AutoFilterMode = False
End If
'删除内容不是"李嘉午" Or "李永世"的单元格所在的行
Dim irow
irow = 1
Do While Sheets("sheet1").Cells(1 + irow, 20) = "李嘉午" Or Sheets("sheet1").Cells(1 + irow, 20) = "李永世"
irow = irow + 1
If Sheets("sheet1").Cells(1 + irow, 20) <> "李嘉午" And Sheets("sheet1").Cells(1 + irow, 20) <> "李永世" Then
Sheets("sheet1").Cells(1 + irow, 20).EntireRow.Delete
End If
If Sheets("sheet1").Cells(1 + irow, 20) = "" Then
Exit Do
End If
Loop
'基本视图部分
'基本视图表头
'判断是否存在sheet2和sheet3,如果不存在增加之
Dim sh As Worksheet
On Error Resume Next
For k = 2 To 3
Set sh = Sheets("sheet" & k)
If sh Is Nothing Then
Sheets.Add.name = "sheet" & k
End If
Set sh = Nothing
Next k
'Dim iresponse As Integer
' iresponse = MsgBox("请确认要做基本视图的Sheet2是否存在，并原始数据在Sheet1", vbYesNo)
' If iresponse = vbYes Then
Sheets("sheet2").Activate
Range("A1").Activate
Range("A1") = "物料编码"
Range("B1") = "行业领域"
Range("C1") = "物料类型"
Range("D1") = "物料描述"
Range("E1") = "基本计量单位"
Range("F1") = "产品组"
Range("G1") = "大小/量纲"
Range("H1") = "钢种"
Range("I1") = "交货标准"
Range("J1") = "物料组"
Range("K1") = "不锈钢标志"
Range("L1") = "密度"
Range("M1") = "结晶器类型"
Range("N1") = "DHCR标志"
Range("O1") = "类别"
'Else
'Exit Sub
' End If
'基本视图实体部分
Dim i As Integer
Dim j As Integer
Dim fourth
Dim second
Dim middle
j = Sheets("sheet1").Range("A65536").End(xlUp).Row
'MsgBox "物料编码数量" & j - 1
With Sheets("sheet2")
For i = 1 To j - 1
.Cells(3 + i - 1, 1) = Sheets("sheet1").Cells(2 + i - 1, 1)
.Cells(3 + i - 1, 2) = "G"
.Cells(3 + i - 1, 3) = Sheets("sheet1").Cells(2 + i - 1, 3)
.Cells(3 + i - 1, 4) = Sheets("sheet1").Cells(2 + i - 1, 2)
.Cells(3 + i - 1, 5) = "TON"
.Cells(3 + i - 1, 7) = Sheets("sheet1").Cells(2 + i - 1, 7) & "*" & Sheets("sheet1").Cells(2 + i - 1, 8) & "*" & Sheets("sheet1").Cells(2 + i - 1, 9)
.Cells(3 + i - 1, 8) = Sheets("sheet1").Cells(2 + i - 1, 6)
.Cells(3 + i - 1, 9) = Sheets("sheet1").Cells(2 + i - 1, 15)
fourth = Left(Cells(3 + i - 1, 1), 4)
second = Left(Cells(3 + i - 1, 1), 2)
middle = Mid(Cells(3 + i - 1, 1), 3, 2)
' MsgBox ("middle=" & middle)
' MsgBox ("Fourth=" & fourth)
'确定物料组
Select Case fourth
Case "LPS1", "LPS4"
.Cells(3 + i - 1, 10) = "HA28"
Case "LPS2", "LPS3", "LPS5"
.Cells(3 + i - 1, 10) = "HA27"
Case "LFS1", "LFS4"
.Cells(3 + i - 1, 10) = "HA43"
Case "LFS2", "LFS3", "LFS5"
.Cells(3 + i - 1, 10) = "HA42"
Case "GDS1", "GDS4"
.Cells(3 + i - 1, 10) = "HA34"
Case "GDS2", "GDS3", "GDS5"
.Cells(3 + i - 1, 10) = "HA33"
Case Else
If second = "GD" Then
.Cells(3 + i - 1, 10) = "HA22"
Else
.Cells(3 + i - 1, 10) = "HA10"
End If
End Select
'确定不锈钢标志
Select Case middle
Case "S1", "S2", "S3", "S4", "S5"
.Cells(3 + i - 1, 11) = 1
Case Else
.Cells(3 + i - 1, 11) = 0
End Select
'确定密度
Select Case middle
Case "S1", "S4"
.Cells(3 + i - 1, 12) = 7.75
Case "S2", "S3", "S5"
.Cells(3 + i - 1, 12) = 7.95
Case Else
.Cells(3 + i - 1, 12) = 7.85
End Select
.Cells(3 + i - 1, 13) = Sheets("sheet1").Cells(2 + i - 1, 7) & "*" & Sheets("sheet1").Cells(2 + i - 1, 8)
.Cells(3 + i - 1, 15) = Sheets("sheet1").Cells(2 + i - 1, 5)
Next i
End With
Sheets("sheet2").name = "基本视图"
'MRP视图部分
'MRP视图表头
With Sheets("sheet3")
.Range("A2") = "物料"
.Range("B2") = "物料描述"
.Range("C2") = "物料类型"
.Range("D2") = "工厂"
.Range("E1") = "MRP1"
.Range("E2") = "MRP类型"
.Range("F2") = "MRP控制者"
.Range("G2") = "批量"
.Range("H1") = "MRP2"
.Range("H2") = "采购类型"
.Range("I2") = "特殊采购类型"
.Range("J2") = "计划边际码"
.Range("K1") = "MRP3"
.Range("K2") = "策略组"
.Range("L2") = "消耗模式"
.Range("M2") = "逆向消耗期间"
.Range("N2") = "向前消耗期间"
.Range("O2") = "可用性检查"
.Range("P1") = "MRP4"
.Range("P2") = "独立/集中"
.Range("Q1") = "工作计划"
.Range("Q2") = "生产计划参数文件"
.Range("R2") = "生产仓储地点"
End With
'MRP视图主体部分
Dim plant
Dim middlemrp
With Sheets("sheet3")
For i = 0 To j - 2
.Cells(3 + i, 1) = Sheets("sheet1").Cells(2 + i, 1)
.Cells(3 + i, 2) = Sheets("sheet1").Cells(2 + i, 2)
.Cells(3 + i, 3) = Sheets("sheet1").Cells(2 + i, 3)
'工厂
plant = Left(Sheets("sheet1").Cells(2 + i, 19), 4)
Select Case plant
Case "6220"
.Cells(3 + i, 4) = "6220"
Case "6240"
.Cells(3 + i, 4) = "6240"
Case Else
.Cells(3 + i, 4) = "Flase"
MsgBox ("工厂号错误,得到的工厂号为" & plant)
End Select
.Cells(3 + i, 5) = "M0"
'确定 "G01"or"G02"
middlemrp = Mid(Cells(3 + i, 1), 3, 2)
Select Case middlemrp
Case "S1", "S2", "S3", "S4", "S5"
.Cells(3 + i, 6) = "G01"
Case Else
.Cells(3 + i, 6) = "G02"
End Select
.Cells(3 + i, 7) = "EX"
.Cells(3 + i, 8) = "X"
.Cells(3 + i, 10).NumberFormatLocal = "@"
.Cells(3 + i, 10) = "000"
.Cells(3 + i, 11) = "91"
.Cells(3 + i, 12) = "1"
.Cells(3 + i, 13) = "30"
.Cells(3 + i, 15).NumberFormatLocal = "@"
.Cells(3 + i, 15) = "02"
.Cells(3 + i, 16) = "2"
.Cells(3 + i, 17) = "PP01"
'库存地
Select Case Sheets("sheet3").Cells(3 + i, 4)
Case "6220"
.Cells(3 + i, 18) = "6222"
Case "6240"
.Cells(3 + i, 18) = "6242"
Case Else
.Cells(3 + i, 18) = "Flase"
End Select
Next i
End With
Sheets("sheet3").name = "MRP"
'保存工作簿
Dim sname
Dim spath
Dim rename
Dim length
Dim ssname
sname = ActiveWorkbook.name
spath = ActiveWorkbook.path
length = Len(sname)
ssname = Left(sname, length - 4)
'MsgBox ssname
rename = spath & "\" & ssname
'MsgBox rename
ActiveWorkbook.SaveAs (rename & " 基本视图 MRP 6220 6240.xls")
ActiveWorkbook.Close SaveChanges:=True
End Sub
[ 本帖最后由 lijiawu1122 于 2011-3-17 20:01 编辑 ] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-3-17 18:01
