焊接材料定额表源代码.doc

Dim arrFilePath(1 To 500) As String
Private Sub cbtnImport_Click()

If Trim(Me.txtFolderPath.Text) = "" Then
MsgBox "请输入要导入的参数文件", vbOKOnly, "提示窗口"
Exit Sub
End If

'Call Clear
Sheet2.Clear

Call ImportData(Me.txtFolderPath.Text, Me.txtShipName.Text, Me.txtPhaeNo.Text)

'Dim irows As Integer '已填写数据行数

'irows = Sheet2.UsedRange.Rows.count
'Sheet2.Cells(irows + 1, 1) = irows

Sheet2.addtitle '画出标题

Call searchpart

'--------------------------------------

MsgBox "数据已生成", vbOKOnly, "提示窗口"
Sheet2.Activate
End Sub

Private Sub ImportData(folderPath As String, shipName As String, phaseNo As String)
Dim length, i, j As Integer
Dim rowIndex As Integer

Call mySearch(folderPath)
length = UBound(arrFilePath) - LBound(arrFilePath) + 1

rowIndex = 5

If length = 0 Then
MsgBox "没有可导入的参数文件.", vbOKOnly, "提示窗口"
Exit Sub
End If

Sheet2.Range("K2") = shipName
Sheet2.Range("L2") = phaseNo

For i = 1 To length
If arrFilePath(i) = "" Then

Sheet2.Cells(rowIndex, 1) = "总和"
Sheet2.Cells(rowIndex, 2) = "=SUM(B5:B" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 3) = "=COUNTA(C5:C" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 4) = "=COUNTA(D5:D" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 9) = "=SUM(I5:I" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 10) = "=SUM(J5:J" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 11) = "=SUM(K5:K" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 12) = "=SUM(L5:L" & rowIndex - 2 & ")"
Sheet2.Cells(rowIndex, 13) = "=SUMPRODUCT(M5:M" & rowIndex - 2 & ",I5:I" & rowIndex - 2 & " )/SUM(I5:I" & rowIndex - 2 & ")"

Exit Sub
End If
rowIndex = ReadFile(arrFilePath(i), rowIndex)
Next i

End Sub

Private Function ReadFile(FileName As String, rowIndex As Integer) As Integer
Dim line() As String, partName() As String
Dim a As String
Dim name As String, length As String, width As String, thickness As String, quality As String
Dim marking As String, burning As String, idle As String
Dim i, j As Integer, totalArea As Double
Dim isExit As Boolean

j = 1
totalArea = 0

Open FileName For Input As #1
Do While EOF(1) = False
DoEvents
isExit = False
Line Input #1, a
If InStr(1, a, "=", vbTextCompare) > 0 Then
line = Split(a, "=")

If line(0) = "NEST_NAME" Then '焊缝分类
name = line(1)

ElseIf line(0) = "RAW_LENGTH" Then 'LENGTH
length = line(1)

ElseIf line(0) = "RAW_WIDTH" Then 'WIDTH
width = line(1)

ElseIf line(0) = "RAW_THICKNESS" Then 'THICKNESS
thickness = line(1)

ElseIf line(0) = "QUALITY" Then 'QUALITY
quality = line(1)

ElseIf line(0) = "PART_AREA" Then 'Area
totalArea = totalArea + line(1)

ElseIf line(0) = "TOTAL_MARKING" Then
marking = line(1)

ElseIf line(0) = "TOTAL_BURNING" Then
burning = line(1)

ElseIf line(0) = "TOTAL_IDLE" Then
idle = line(1)

ElseIf line(0) = "PARTNAME_LONG" Then
If Sheet2.Cells(rowIndex, 1) = "" Then

Sheet2.Cells(rowIndex, 1) = line(1)
Sheet2.Cells(rowIndex, 2) = Sheet2.Cells(rowIndex, 2) + 1
j = rowIndex

Else
For i = rowIndex To j
If Sheet2.Cells(i, 1) = line(1) Then
Sheet2.Cells(i, 2) = Sheet2.Cells(i, 2) + 1
isExit = True
Exit For
End If
Next i

If isExit = False Then
Sheet2.Cells(j + 1, 1) = line(1)
Sheet2.Cells(j + 1, 2) = 1
j = j + 1
End If

End If

End If
End If
Loop
Close #1

'*********************************************

Call Sheet2.myMerge("D", rowIndex, j) '合并单元格
Call Sheet2.myMerge("E", rowIndex, j)
Call Sheet2.myMerge("F", rowIndex, j)
Call Sheet2.myMerge("G", rowIndex, j)
Call Sheet2.myMerge("H", rowIndex, j)
Call Sheet2.myMerge("I", rowIndex, j)
Call Sheet2.myMerge("J", rowIndex, j)
Call Sheet2.myMerge("K", rowIndex, j)
Call Sheet2.myMerge("L", rowIndex, j)
Call Sheet2.myMerge("M", rowIndex, j)
'Call Sheet2.myMerge("N", rowIndex, j)

Sheet2.Range("D" & rowIndex) = name
Sheet2.Range("E" & rowIndex) = length
Sheet2.Range("F" & rowIndex) = width
Sheet2.Range("G" & rowIndex) = thickness
Sheet2.Range("H" & rowIndex) = quality
Sheet2.Range("I" & rowIndex) = "=E" & rowIndex & "*F" & rowIndex & "* G" & rowIndex & "* 7.85 / 1000000"
Sheet2.Range("J" & rowIndex) = marking / 1000
Sheet2.Range("K" & rowIndex) = burning / 1000
Sheet2.Range("L" & rowIndex) = idle / 1000
Sheet2.Range("M" & rowIndex) = "=" & totalArea & "*G" & rowIndex & "*7.85/1000000/I" & rowIndex

'***********************************************

For k = rowIndex To j
If Left(Sheet2.Cells(k, 1), 3) <> Mid(Sheet2.Cells(rowIndex, 4), 3, 3) And Left(Sheet2.Cells(k, 1), 3) <> Me.txtKeywork.Text Then
Sheet2.Cells(k, 3) = Left(Sheet2.Cells(k, 1), 3)
End If
Next k
ReadFile = j + 2

End Function

Sub mySearch(folderPath As String)
Dim fs, i
Set fs = Application.FileSearch
With fs
.LookIn = folderPath & "/"
.FileName = "*.gen"
.SearchSubFolders = False
If .Execute > 0 Then
' MsgBox "There were " & .FoundFiles.count & _
" file(s) found."
For i = 1 To .FoundFiles.count
arrFilePath(i) = .FoundFiles(i)
Next i
'Sheets(3).Range("A1").Resize(.FoundFiles.count) = Application.Transpose(arrFilePath) '
Else
MsgBox "指定的文件夹找不到参数文件."
End If
End With
End Sub

Private Sub cbtnReset_Click()

Call Clear
Sheet1.Activate
End Sub

Private Sub Clear()
Sheet2.Clear
Sheet2.Range("K2") = ""
Sheet2.Range("L2") = ""
Sheet4.Clear
Sheet5.Clear
End Sub

Private Sub GetFileName()

Dim FilePath, FileName, ub

FilePath = Application.GetOpenFileName("Excel97-2003 Files (*.xls),*.xls")

If FilePath <> "False" Then

ub = UBound(Split(FilePath, "\"))

FileName = Split(FilePath, "\")(ub)

FilePath = Left(FilePath, Len(FilePath) - Len(FileName))

MsgBox "FilePath:" & FilePath & vbCrLf & "FileName:" & FileName

End If

End Sub

Sub GetFileName4()

Sheet4.Clear

Dim FilePath, FileName, fullFileName As String, ub
FilePath = Application.GetOpenFileName("Excel97-2003 Files (*.xls),*.xls")
If FilePath <> "False" Then
ub = UBound(Split(FilePath, "\"))
FileName = Split(FilePath, "\")(ub)
FilePath = Left(FilePath, Len(FilePath) - Len(FileName))
fullFileName = FilePath & FileName
Dim thisexcelname As String
thisexcelname = Application.ActiveWorkbook.FullName

'Sheet4.Cells(5, 1) = FilePath & FileName
'Sheet4.Cells(6, 1) = thisexcelname

Dim wkbk As Workbook
Set actbok = ThisWorkbook
Set wkbk = Workbooks.Open(fullFileName)
wkbk.Sheets(1).UsedRange.Copy
Sheet4.Activate
actbok.ActiveSheet.Range("A1").Activate
ActiveSheet.Paste
'ThisWorkbook.Sheets(4).Range("A1").Paste、
Application.CutCopyMode = False
wkbk.Close sacechanges = False
Application.CutCopyMode = True
Sheet1.Activate

End If

End Sub

Sub GetFileName5()

Sheet5.Clear

Dim FilePath, FileName, fullFileName As String, ub
FilePath = Application.GetOpenFileName("Excel97-2003 Files (*.xls),*.xls")
If FilePath <> "False" Then
ub = UBound(Split(FilePath, "\"))
FileName = Split(FilePath, "\")(ub)
FilePath = Left(FilePath, Len(FilePath) - Len(FileName))
fullFileName = FilePath & FileName
Dim thisexcelname As String
thisexcelname = Application.ActiveWorkbook.FullName

'Sheet4.Cells(5, 1) = FilePath & FileName
'Sheet4.Cells(6, 1) = thisexcelname

Dim wkbk As Workbook
Set actbok = ThisWorkbook
Set wkbk = Workbooks.Open(fullFileName)、
wkbk.Sheets(1).UsedRange.Copy、
Sheet5.Activate
actbok.ActiveSheet.Range("A1").Activate
ActiveSheet.Paste
'ThisWorkbook.Sheets(4).Range("A1").Paste
Application.CutCopyMode = False
wkbk.Close sacechanges = False
Application.CutCopyMode = True
Sheet1.Activate

End If

End Sub

Private Sub CommandButton1_Click()

Call GetFileName4
End Sub

Private Sub CommandButton2_Click()

Call GetFileName5

End Sub

Private Sub CommandButton3_Click()

Dim MJ As Integer, MJs As Integer
MJ = 11
MJs = MJ + 2
Call Sheet2.myMerge2("A", "I", MJ - 1, MJ - 1)
Sheet2.Range("A" & MJ - 1) = "分段"
Call Sheet2.myMerge("A", MJ, MJs)
Sheet2.Range("A" & MJ) = "焊缝长度"
Call Sheet2.myMerge("B", MJ, MJs)
Sheet2.Range("B" & MJ) = "焊材"
Call Sheet2.myMerge("C", MJ, MJs)
Sheet2.Range("C" & MJ) = ""
Call Sheet2.myMerge("D", MJ, MJs)
Sheet2.Range("D" & MJ) = ""
Call Sheet2.myMerge2("E", "G", MJ, MJs)
Sheet2.Range("E" & MJ) = ""
Call Sheet2.myMerge("H", MJ, MJs)
Sheet2.Range("H" & MJ) = ""
Call Sheet2.myMerge("I", MJ, MJs)
Sheet2.Range("I" & MJ) = ""

Dim trsheet1 As Worksheet
Dim trsheetrange1 As Excel.Range

Dim i1, j1, k1, m1 As Long
Dim faarray(10000, 20) As String
Dim faarray1(10000, 20) As String
Dim DUICHENG As Long
Dim DUICHENG1 As Long

DUICHENG = Me.txtKeywork.Text

k1 = 1

Set trsheet1 = ThisWorkbook.Worksheets(4)
Set trsheetrange1 = trsheet1.Range("A:H")

For i1 = 5 To 10000
If i1 > 600 Then
If trsheetrange1(i1, 2) = "" And trsheetrange1(i1 - 1, 2) = "" And trsheetrange1(i1 - 2, 2) = "" And trsheetrange1(i1 - 3, 2) = "" _
And trsheetrange1(i1 - 4, 2) = "" And trsheetrange1(i1 - 5, 2) = "" And trsheetrange1(i1 - 6, 2) = "" And trsheetrange1(i1 - 7, 2) = "" _
And trsheetrange1(i1 - 8, 2) = "" And trsheetrange1(i1 - 9, 2) = "" And trsheetrange1(i1 - 10, 2) = "" And trsheetrange1(i1 - 11, 2) = "" _
And trsheetrange1(i1 - 12, 2) = "" And trsheetrange1(i1 - 13, 2) = "" And trsheetrange1(i1 - 20, 2) = "" Then
Exit For
End If
End If

If Trim(trsheetrange1(i1, 1)) = "" Then
faarray(k1, 1) = faarray(k1 - 1, 1)
Else
faarray(k1, 1) = Trim(trsheetrange1(i1, 1))
End If

faarray(k1, 2) = Trim(trsheetrange1(i1, 2))
'faarray(k1, 11) = Trim(trsheetrange1(i, 1))

faarray(k1, 3) = faarray(k1, 1) & "-" & faarray(k1, 2)

faarray(k1, 4) = Trim(Str(Val(trsheetrange1(i1, 3)) + Val(trsheetrange1(i1, 4)) + Val(trsheetrange1(i1, 5))))

'
faarray(k1, 5) = Trim(trsheetrange1(i1, 13))

faarray(k1, 6) = Trim(trsheetrange1(i1, 10))
faarray(k1, 7) = Trim(trsheetrange1(i1, 9))

faarray(k1, 8) = Trim(trsheetrange1(i1, 11))

faarray(k1, 9) = Left(faarray(k1, 3), 3)

faarray(k1, 10) = Right(Left(faarray(k1, 8), 5), 3)
k1 = k1 + 1

'End If

Next i1

m1 = 1

For j1 = 1 To 10000
If faarray(j1, 9) <> faarray(j1, 10) And faarray(j1, 2) <> "" Then
faarray1(m1, 1) = faarray(j1, 1)
faarray1(m1, 2) = faarray(j1, 2)
faarray1(m1, 3) = faarray(j1, 3)
faarray1(m1, 4) = faarray(j1, 4)
faarray1(m1, 5) = faarray(j1, 5)
faarray1(m1, 6) = faarray(j1, 6)
faarray1(m1, 7) = faarray(j1, 7)
faarray1(m1, 8) = faarray(j1, 8)
faarray1(m1, 9) = faarray(j1, 9)
faarray1(m1, 10) = faarray(j1, 10)

faarray(j1, 1) = ""
faarray(j1, 2) = ""
faarray(j1, 3) = ""
faarray(j1, 4) = ""
faarray(j1, 5) = ""
faarray(j1, 6) = ""
faarray(j1, 7) = ""
faarray(j1, 8) = ""
faarray(j1, 9) = ""
faarray(j1, 10) = ""

m1 = m1 + 1
Else
faarray(j1, 1) = ""
faarray(j1, 2) = ""
faarray(j1, 3) = ""
faarray(j1, 4) = ""
faarray(j1, 5) = ""
faarray(j1, 6) = ""
faarray(j1, 7) = ""
faarray(j1, 8) = ""
faarray(j1, 9) = ""
faarray(j1, 10) = ""
End If
Next j1
'Else

Sheet5.Range("A:L") = faarray()
Sheet6.Range("A:L") = faarray1()
Erase faarray()
Erase faarray1()
'Sheet5.Range("A1") = "HAHAHA"

End Sub

Sub searchpart()

Dim i1 As Long, i2 As Long, j1 As Long, j2 As Long
Dim k1 As Long, k2 As Long, m1 As Long, m2 As Long
Dim L1 As Long, l2 As Long, P1 As Long, p2 As Long
Dim faarray(10000, 20) As String, faarra