Private Sub AddData()
Dim FileName As Variant
Dim xlBook As Workbook
Dim xlApp As Application
Dim xlSheet As Worksheet
Dim tmp_filename As String
Dim tmp_str As String
Dim tmp_proname As String
Dim tmp_type As String
Dim tmp_s As String
Dim tmp_flag As String
Dim isContain As Boolean
Set xlApp = New Excel.Application
Dim tmp_n As Integer
'打开文件对话框返回的文件名,是一个全路径文件名,其值也可能是False,因此类型为Variant
Dim ws As Worksheet '存储文件路径名和文件名的工作表
Set ws = Worksheets(2) '设置工作表
On Error GoTo ERROR1
FileName = Application.GetOpenFilename("Excel 文件 (*.xls),*.xls", MultiSelect:=True)
tmp_n = Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row + 1 '最后一行
If tmp_n Mod 2 <> 0 Then
tmp_n = tmp_n + 1
End If
If IsArray(FileName) Then
For n = 1 To UBound(FileName)
tmp_filename = FileName(n)
Set xlBook = xlApp.Workbooks.Open(tmp_filename)
Set xlSheet = xlBook.Worksheets("表一")
tmp_str = Trim(Mid(xlSheet.Cells(4, 1), 6))
tmp_proname = Left(tmp_str, Len(tmp_str) - 6)
tmp_type = Right(tmp_str, 6)
'先遍历有没有这个项目的数据
tmp_flag = tmp_n
isContain = False
For m = 4 To tmp_n Step 2
If (ws.Cells(m, 3) = tmp_proname) Then
tmp_flag = m
isContain = True
Exit For
End If
Next
If isContain Then
'有的话更新
For j = 1 To Len(tmp_type)
If Mid(tmp_type, j, 2) = "设备" Then
tmp_flag = tmp_flag + 1
End If
Next
If tmp_flag Mod 2 = 0 Then
ws.Cells(tmp_flag, 3).Value = tmp_proname
Else
ws.Cells(tmp_flag - 1, 3).Value = tmp_proname
End If
ws.Cells(tmp_flag, 19).Value = xlSheet.Cells(10, 5)
ws.Cells(tmp_flag, 20) = xlSheet.Cells(9, 7)
Set xlSheet = xlBook.Worksheets("表二")
ws.Cells(tmp_flag, 22) = xlSheet.Cells(13, 4)
Set xlSheet = xlBook.Worksheets("表五(甲)")
ws.Cells(tmp_flag, 24) = xlSheet.Cells(8, 6)
ws.Cells(tmp_flag, 26) = xlSheet.Cells(11, 6)
ws.Cells(tmp_flag, 27) = xlSheet.Cells(14, 6)
ws.Cells(tmp_flag, 28) = xlSheet.Cells(15, 6)
ws.Cells(tmp_flag, 29) = xlSheet.Cells(20, 6)
ws.Cells(tmp_flag, 30) = xlSheet.Cells(21, 6)
Else
'没有的话在后面添加
Range(Cells(tmp_flag, 3), Cells(tmp_flag + 1, 3)).Merge '合并单元格
For j = 1 To Len(tmp_type)
If Mid(tmp_type, j, 2) = "设备" Then
tmp_flag = tmp_flag + 1
End If
Next
If tmp_flag Mod 2 = 0 Then
ws.Cells(tmp_flag, 3).Value = tmp_proname
Else
ws.Cells(tmp_flag - 1, 3).Value = tmp_proname
End If
ws.Cells(tmp_flag, 19).Value = xlSheet.Cells(10, 5)
ws.Cells(tmp_flag, 20) = xlSheet.Cells(9, 7)
Set xlSheet = xlBook.Worksheets("表二")
ws.Cells(tmp_flag, 22) = xlSheet.Cells(13, 4)
Set xlSheet = xlBook.Worksheets("表五(甲)")
ws.Cells(tmp_flag, 24) = xlSheet.Cells(8, 6)
ws.Cells(tmp_flag, 26) = xlSheet.Cells(11, 6)
ws.Cells(tmp_flag, 27) = xlSheet.Cells(14, 6)
ws.Cells(tmp_flag, 28) = xlSheet.Cells(15, 6)
ws.Cells(tmp_flag, 29) = xlSheet.Cells(20, 6)
ws.Cells(tmp_flag, 30) = xlSheet.Cells(21, 6)
tmp_n = tmp_n + 2
End If
xlBook.Close SaveChanges:=False
Next
End If
Exit Sub
ERROR1:
MsgBox (tmp_filename & " 文件格式不正确!")
End Sub
Public Sub 预算()
Dim HelpMenu As CommandBarControl
Dim NewMenu As CommandBarPopup
Dim MenuItem As CommandBarControl
Dim SubMenuItem As CommandBarButton
On Error Resume Next
'如果菜单已存在,则删除该菜单
CommandBars(1).Controls("预算(&S)").Delete
'利用ID属性查找帮助菜单
Set HelpMenu = CommandBars(1).FindControl(ID:=30010)
If HelpMenu Is Nothing Then
'如果该菜单不存在,则将新菜单添加到末尾
'设置新菜单为临时的
Set NewMenu = CommandBars(1).Controls _
.add(Type:=msoControlPopup, Temporary:=True)
Else
'将新菜单添加到帮助菜单之前
Set NewMenu = CommandBars(1).Controls _
.add(Type:=msoControlPopup, Before:=HelpMenu.Index, _
Temporary:=True)
End If
'添加菜单标题并指定热键
NewMenu.Caption = "预算(&S)"
'添加第一个菜单项
Set MenuItem = NewMenu.Controls.add _
(Type:=msoControlButton)
With MenuItem
.Caption = "数据(&D)..."
.FaceId = 162
.OnAction = "AddData"
End With
End Sub