焊接材料定额表源代码

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 faarray2 10000 20 As String Dim faarray1 10000 20 As String faarray12 10000 20 As String Dim faarray22 10000 20 As String Dim faarray33 1 20 As String Dim f1 As Long f2 As Long f12 As Long Dim trsheet1 As Worksheet Dim trsheetrange1 As Excel Range Dim trsheet12 As Worksheet Dim trsheetrange12 As Excel Range Dim DUICHENG As String Dim HANGSHU As String Dim BENFENDUAN As String HANGSHU Sheet2 UsedRange Rows count 1 DUICHENG Me txtKeywork Text k1 1 k2 1 Set trsheet1 ThisWorkbook Worksheets 4 Set trsheet12 ThisWorkbook Worksheets 5 Set trsheetrange1 trsheet1 Range A H Set trsheetrange12 trsheet12 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 Next i1 For i2 5 To 10000 If i2 600 Then If trsheetrange12 i2 2 And trsheetrange12 i2 1 2 And trsheetrange12 i2 2 2 And trsheetrange12 i2 3 2 And trsheetrange12 i2 4 2 And trsheetrange12 i2 5 2 And trsheetrange12 i2 6 2 And trsheetrange12 i2 7 2 And trsheetrange12 i2 8 2 And trsheetrange12 i2 9 2 And trsheetrange12 i2 10 2 And trsheetrange12 i2 11 2 And trsheetrange12 i2 12 2 And trsheetrange12 i2 13 2 And trsheetrange12 i2 20 2 Then Exit For End If End If If Trim trsheetrange12 i2 1 Then faarray2 k2 1 faarray2 k2 1 1 Else faarray2 k2 1 Trim trsheetrange12 i2 1 End If faarray2 k2 2 Trim trsheetrange12 i2 2 faarray k1 11 Trim trsheetrange1 i 1 faarray2 k2 3 faarray2 k2 1 faarray2 k2 2 faarray2 k2 4 Trim Str Val trsheetrange12 i2 3 Val trsheetrange12 i2 4 Val trsheetrange12 i2 5 faarray2 k2 5 Trim trsheetrange12 i2 13 faarray2 k2 6 Trim trsheetrange12 i2 10 faarray2 k2 7 Trim trsheetrange12 i2 9 faarray2 k2 8 Trim trsheetrange12 i2 11 faarray2 k2 9 Left faarray2 k2 3 3 faarray2 k2 10 Right Left faarray2 k2 8 5 3 k2 k2 1 Next i2 For L1 1 To 10000 If faarray L1 9 faarray L1 10 And faarray L1 9 Then BENFENDUAN faarray L1 9 Exit For End If Next L1 For P1 1 To 10000 If faarray P1 9 Then If faarray P1 9 DUICHENG Then faarray P1 9 BENFENDUAN End If End If Next P1 For p2 1 To 10000 If faarray2 p2 9 Then If faarray2 p2 9 DUICHENG Then faarray2 p2 9 BENFENDUAN End If End If Next p2 m1 1 For j1 1 To 10000 If faarray j1 9 faarray j1 10 And faarray j1 2 And faarray j1 9 BENFENDUAN 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 m2 1 For j2 1 To 10000 If faarray2 j2 9 faarray2 j2 10 And faarray2 j2 2 Then faarray12 m2 1 faarray2 j2 1 faarray12 m2 2 faarray2 j2 2 faarray12 m2 3 faarray2 j2 3 faarray12 m2 4 faarray2 j2 4 faarray12 m2 5 faarray2 j2 5 faarray12 m2 6 faarray2 j2 6 faarray12 m2 7 faarray2 j2 7 faarray12 m2 8 faarray2 j2 8 faarray12 m2 9 faarray2 j2 9 faarray12 m2 10 faarray2 j2 10 faarray2 j2 1 faarray2 j2 2 faarray2 j2 3 faarray2 j2 4 faarray2 j2 5 faarray2 j2 6 faarray2 j2 7 faarray2 j2 8 faarray2 j2 9 faarray2 j2 10 m2 m2 1 Else faarray2 j2 1 faarray2 j2 2 faarray2 j2 3 faarray2 j2 4 faarray2 j2 5 faarray2 j2 6 faarray2 j2 7 faarray2 j2 8 faarray2 j2 9 faarray2 j2 10 End If Next j2 f2 1 For f1 1 To 10000 If faarray1 f1 1 Then faarray22 f2 1 faarray1 f1 1 faarray22 f2 2 faarray1 f1 2 faarray22 f2 3 faarray1 f1 3 faarray22 f2 4 faarray1 f1 4 faarray22 f2 5 faarray1 f1 5 faarray22 f2 6 faarray1 f1 6 faarray22 f2 7 faarray1 f1 7 faarray22 f2 8 faarray1 f1 8 faarray22 f2 9 faarray1 f1 9 faarray22 f2 10 faarray1 f1 10 f2 f2 1 Else For f12 1 To 10000 If faarray12 f12 1 Then faarray22 f2 1 faarray12 f12 1 faarray22 f2 2 faarray12 f12 2 faarray22 f2 3 faarray12 f12 3 faarray22 f2 4 faarray12 f12 4 faarray22 f2 5 faarray12 f12 5 faarray22 f2 6 faarray12 f12 6 faarray22 f2 7 faarray12 f12 7 faarray22 f2 8 faarray12 f12 8 faarray22 f2 9 faarray12 f12 9 faarray22 f2 10 faarray12 f12 10 f2 f2 1 Else Exit For End If Next f12 Exit For End If Next f1 Dim i3 As Long Dim j3 As Long For i3 1 To 10000 If faarray22 i3 1 Then For j3 i3 1 To 10000 If faarray22 j3 1 Then If faarray22 i3 8 faarray22 j3 8 Then faarray33 1 1 faarray22 i3 1 faarray33 1 2 faarray22 i3 2 faarray33 1 3 faarray22 i3 3 faarray33 1 4 faarray22 i3 4 faarray33 1 5 faarray22 i3 5 faarray33 1 6 faarray22 i3 6 faarray33 1 7 faarray22 i3 7 faarray33 1 8 faarray22 i3 8 faarray33 1 9 faarray22 i3 9 faarray33 1 10 faarray22 i3 10 faarray22 i3 1 faarray22 j3 1 faarray22 i3 2 faarray22 j3 2 faarray22 i3 3 faarray22 j3 3 faarray22 i3 4 faarray22 j3 4 faarray22 i3 5 faarray22 j3 5 faarray22 i3 6 faarray22 j3 6 faarray22 i3 7 faarray22 j3 7 faarray22 i3 8 faarray22 j3 8 faarray22 i3 9 faarray22 j3 9 faarray22 i3 10 faarray22 j3 10 faarray22 j3 1 faarray33 1 1 faarray22 j3 2 faarray33 1 2 faarray22 j3 3 faarray33 1 3 faarray22 j3 4 faarray33 1 4 faarray22 j3 5 faarray33 1 5 faarray22 j3 6 faarray33 1 6 faarray22 j3 7 faarray33 1 7 faarray22 j3 8 faarray33 1 8 faarray22 j3 9 faarray33 1 9 faarray22 j3 10 faarray33 1 10 End If Else Exit For End If Next j3 Else Exit For End If Next i3 Dim h1 As Long 数据写入表格 Dim h2 As Integer Dim HANGSHU1 As String HANGSHU1 Sheet2 UsedRange Rows count For h1 1 To 10000 h2 h1 HANGSHU1 If faarray22 1 1 Then Sheet2 Cells h2 1 1 无 End If If faarray22 h1 1 Then Sheet2 Cells h2 1 faarray22 h1 3 Sheet2 Cells h2 2 faarray22 h1 4 Sheet2 Cells h2 3 faarray22 h1 10 Sheet2 Cells h2 4 faarray22 h1 8 Call S