Im having a problem.
We got so called *.mmm files in this company,
those files just contain plain text with some data.
The vba is scripted to put those data into an xml-sheet.
But, the problem is: it is built on 2003, 2003 only supports 256 columns.
We need more nowadays, so 2007 is the solution, but the macro isnt working here.
We use Application.FileSearch to get the files.
and these are the code:
Create total from *.mmm files in an assigned directory which will be imported in an other sheet in excel
Module 1.
Read the content of the *.mmm files and put them into the excel sheet.
Check, Delete and sometimes create a filesheet
Module 3.
Much thanks in advance, we really need this asap!
Jesper
We got so called *.mmm files in this company,
those files just contain plain text with some data.
The vba is scripted to put those data into an xml-sheet.
But, the problem is: it is built on 2003, 2003 only supports 256 columns.
We need more nowadays, so 2007 is the solution, but the macro isnt working here.
We use Application.FileSearch to get the files.
and these are the code:
Create total from *.mmm files in an assigned directory which will be imported in an other sheet in excel
Module 1.
Module 2.Public projectNumber As String
Public directory As String
Public afbreekCriterium As Boolean
Public numberOfImportRecords As Integer
Public directoryLL As String
Public directorySpecmat As String
Public naamRange As Range
Public numberOfIsoDrawings As Integer
Public tekeningNummerLijst(500, 4) As String
Public itemAantal(1000, 1000) As Variant
Public itemCode(1000) As String
Public itemTekening(500) As String
Public totaalTekeningNummersOud As Integer
Public totaalTekeningNummersNieuw As Integer
Public Sub TotalMto()
Controle
If afbreekCriterium = True Then
Exit Sub
End If
SheetsImportAdd
CopyMmmFiles
'ImportData
If afbreekCriterium = True Then
Exit Sub
End If
AddToImportFromLL
AddToImportFromSPECMAT
SheetsTekeningnummersAdd
AddToTekeningnummersFromImport
GenImportKey_Click
ImportOptellen 'optellen van onder andere bochten die getrimmed zijn
'AddToTekeningnummersFromLL
TekeningnummersToevoegen
DataImportToMTO
End Sub
Public Sub TotalMtoRevision()
Controle
If afbreekCriterium = True Then
Exit Sub
End If
SheetsImportAdd
CopyMmmFiles
'ImportData
If afbreekCriterium = True Then
Exit Sub
End If
AddToImportFromLL
AddToImportFromSPECMAT
'SheetsTekeningnummersAdd
AddToTekeningnummersFromImportRevision
GenImportKey_Click
ImportOptellen 'optellen van onder andere bochten die getrimmed zijn
TekeningnummersToevoegenRevision
DataImportToMTORevision
End Sub
Public Sub Controle()
'##########################################################
' Controle op een aantal projectnummer
' Controle op een aantal COMBI.bat file
' Deze dient in dezelfde directory te staan als de materiaal files
' Controle op aanwezigheid van materiaal files met extensie mmm
' Combineren van de *.mmm files met COMBI.bat
'
' H.J.Timmerman d.d. 26-01-2010
'##########################################################
afbreekCriterium = False
Sheets("HANDLEIDING").Select
projectNumber = Sheets("MTO").Cells(2, 12).Value
directory = Sheets("MTO").Cells(3, 14).Value
directoryLL = Sheets("MTO").Cells(4, 14).Value
directorySpecmat = Sheets("MTO").Cells(5, 14).Value
'testen of er een projectnummer is ingevuld
If projectNumber = "" Or projectNumber = " " Then
MsgBox "Er is geen projectnummer ingevuld in sheet MTO "
afbreekCriterium = True
Exit Sub
Else
If Len(projectNumber) > 5 Then
MsgBox "Foutief projectnummer in sheet MTO: " & projectNumber
afbreekCriterium = True
Exit Sub
Else
'MsgBox "Projectnummer is: " & projectNumber
End If
End If
'Testen of er een directory is ingevuld.
If directory = "" Or directory = " " Then
MsgBox "Er is geen directory ingevuld waar de isometrische materiaal bestanden staan. "
afbreekCriterium = True
Exit Sub
Else
'MsgBox "Opgegeven directory is: " & directory
End If
'Testen of er de linelist directory is ingevuld.
If directoryLL = "" Or directoryLL = " " Then
MsgBox "Er is geen Linelist directory ingevuld. "
afbreekCriterium = True
Exit Sub
Else
'MsgBox "Opgegeven Linelist directory is: " & directoryLL
End If
'Testen of er de Specmat directory is ingevuld.
If directorySpecmat = "" Or directorySpecmat = " " Then
MsgBox "Er is geen Specmat directory ingevuld. "
afbreekCriterium = True
Exit Sub
Else
'MsgBox "Opgegeven Specmat directory is: " & directorySpecmat
End If
'Testen of COMBI.Bat aanwezig is
'Set FS = Application.FileSearch
'With FS
' .LookIn = directory
' .FileName = "COMBI.bat"
' If .Execute(SortBy:=msoSortByFileName, _
' SortOrder:=msoSortOrderAscending) > 0 Then
'MsgBox "Het bestand " & .Filename & " is gevonden"
' Else
' MsgBox "Het bestand COMBI.BAT ontbreekt in de directory " & directory
' afbreekCriterium = True
' Exit Sub
' End If
'End With
'Testen of materiaalfiles aanwezig zijn.
Set FS = Application.FileSearch
With FS
.LookIn = directory
.FileName = "*.mmm"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
'MsgBox "Er zijn " & .FoundFiles.Count & " materiaal file(s) gevonden."
Else
MsgBox "Er zijn geen materiaal bestanden in de directory " & directory
afbreekCriterium = True
Exit Sub
End If
End With
'Testen of Linelist aanwezig zijn.
Set FS = Application.FileSearch
With FS
.LookIn = directoryLL
.FileName = "LL.mdb"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
'MsgBox "De linelist is gevonden."
Else
MsgBox "Er is geen Linelist in de directory " & directory
afbreekCriterium = True
Exit Sub
End If
End With
'Testen of Linelist aanwezig zijn.
Set FS = Application.FileSearch
With FS
.LookIn = directorySpecmat
.FileName = "SPECMAT.mdb"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
'MsgBox "De Specmat databse is gevonden."
Else
MsgBox "Er is geen Spectmat database in de directory " & directory
afbreekCriterium = True
Exit Sub
End If
End With
'Vervallen vanwege andere methode van inlezen mmm files
'Uitvoeren Combi.bat
'pad = directory & "\COMBI.BAT"
'Retval = Shell(pad, 1)
'If Retval = Null Then
' MsgBox "Batch bestand kan niet worden uitgevoerd"
' afbreekCriterium = True
' Exit Sub
'End If
'MsgBox "Selecteer pas OK nadat de DOS-box is gesloten"
End Sub
Sub SheetsImportAdd()
'##########################################################
'
' Controle, verwijderen en eventueel aanmaken Import sheet
' H.J.Timmerman d.d. 26-01-2010
'##########################################################
Dim werkblad As Object
Dim aantalBladen As Integer
Dim aanwezig As Boolean
aanwezig = False
aantalBladen = Sheets.Count
For Each werkblad In Sheets
'Debug.Print werkblad.Name
If werkblad.Type = xlWorksheet Then
If werkblad.Name = "Import" Then
aanwezig = True
End If
End If
Next
If Not aanwezig Then
With ActiveWorkbook
.Sheets.Add _
Before:=.Sheets("MTO"), _
Type:=xlWorksheet
End With
ActiveSheet.Name = "Import"
Else
Sheets("Import").Select
Cells.Select
Selection.ClearContents
End If
Sheets("Import").Select
End Sub
Public Sub ImportData()
'##########################################################
' Deze is vervallen en vervangen door CopyMmmFiles
' Importeren van het CSV bestand
' H.J.Timmerman d.d. 26-01-2010
'##########################################################
Sheets("Import").Select
Range("A1").Select
'Ophalen csv bestand
'fileToOpen = Application _
.GetOpenFilename("Text Files (*.csv),*.csv")
'If fileToOpen <> False Then
'MsgBox "Open " & fileToOpen
'End If
'Testen of csv bestand aanwezig zijn.
Set FS = Application.FileSearch
'Debug.Print "fs= " & fs
With FS
.LookIn = directory
'Debug.Print "directory = " & directory
.FileName = "MATERIAL.csv"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
'MsgBox "Materiaal bestand gevonden."
Else
MsgBox "Er is geen materiaal bestand in de directory " & directory
afbreekCriterium = True
Exit Sub
End If
End With
fileToOpen = directory & "\MATERIAL.CSV"
Range("A1").Select
Invoer = "TEXT;" + fileToOpen
With ActiveSheet.QueryTables.Add(Connection:= _
Invoer, Destination:=Range("A2"))
.Name = "MATERIAL_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'######################################################
' Header information
'######################################################
Cells(1, 1).Value = "NEM-code"
Cells(1, 2).Value = "Hoeveelheid"
Cells(1, 3).Value = "Diameter"
Cells(1, 4).Value = "Wanddikte"
Cells(1, 5).Value = "Omschrijving"
Cells(1, 6).Value = "Materiaal"
Cells(1, 7).Value = "Gewicht"
Cells(1, 8).Value = "Shop/Field"
Cells(1, 9).Value = "KKS-nummer"
Cells(1, 10).Value = "Spec"
'Laatste regel verwijderen
Range("A1").Select
i = 2
Do While Cells(i, 1).Value <> ""
i = i + 1
Loop
totaal = i - 1
'Bijzondere teken carriage return???
'Testwaarde1 = Cells(totaal, 1).Value
'Testwaarde2 = Cells(totaal, 2).Value
'Testwaarde3 = Cells(totaal, 3).Value
'If Testwaarde1 <> "" And Testwaarde2 = "" And Testwaarde3 = "" Then
' MsgBox ("waarde is " & Testwaarde1)
'End If
verwijderen = totaal & ":" & totaal
Rows(verwijderen).Select
Selection.Delete Shift:=xlUp
totaal = totaal - 1
'Voorliggende spaties verwijderen
Range("A1").Select
For i = 2 To totaal
'A=1,C=3,E=5,F=6,H=8,I=9
Cells(i, 1).Value = Trim(Cells(i, 1).Value)
Cells(i, 2).Value = Trim(Cells(i, 2).Value)
Cells(i, 3).Value = Trim(Cells(i, 3).Value)
Cells(i, 4).Value = Trim(Cells(i, 4).Value)
Cells(i, 5).Value = Trim(Cells(i, 5).Value)
'Maak meters van de hoeveelheid voor Pipe elementen en gewichten per meter
Description = Cells(i, 5).Value
If Left(Description, 4) = "Pipe" Then
Cells(i, 2).Value = Cells(i, 2).Value / 1000
End If
Cells(i, 6).Value = Trim(Cells(i, 6).Value)
Cells(i, 7).Value = Trim(Cells(i, 7).Value)
Cells(i, 8).Value = Trim(Cells(i, 8).Value)
Cells(i, 9).Value = Trim(Cells(i, 9).Value)
Cells(i, 10).Value = Trim(Cells(i, 10).Value)
SPEC = Cells(i, 10).Value
If Len(SPEC) = 5 Then
Cells(i, 10).Value = "'0" & SPEC
Else
Cells(i, 10).Value = "'" & SPEC
End If
Next
'Sorteren bestand op NEM-code
range_1 = "A2:K" & totaal
Range(range_1).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Public Sub CopyMmmFiles()
'##########################################################
' Maak een overzicht van alle mmm files in een bepaalde directory
' Dit overzicht wordt geplaatst in een worksheet files
'
'
'
'
' H.J.Timmerman d.d. 26-01-2010
'##########################################################
Dim FS As Office.FileSearch
Dim strPath As String
Dim vaFileName As Variant
Dim strMessage As String
Dim i As Long
Dim iCount As Long
Dim ImpRng As Range
Dim FileName As String
Dim r As Long
Dim c As Integer
Dim txt As String
Dim Char As String * 1
Dim Data
Dim j As Integer
Sheets("Import").Select
Range("L2").Select
'######################################################
' Header information
'######################################################
Cells(1, 1).Value = "NEM-code"
Cells(1, 2).Value = "Hoeveelheid"
Cells(1, 3).Value = "Diameter"
Cells(1, 4).Value = "Wanddikte"
Cells(1, 5).Value = "Omschrijving"
Cells(1, 6).Value = "Materiaal"
Cells(1, 7).Value = "Gewicht"
Cells(1, 8).Value = "Shop/Field"
Cells(1, 9).Value = "KKS-nummer"
Cells(1, 10).Value = "Spec"
Cells(1, 11).Value = "ISO-number"
i = 2
Set FS = Application.FileSearch
strPath = Sheets("MTO").Cells(3, 14).Value
Mini = Len(strPath)
With FS
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileName = "*.mmm"
.FileType = msoFileTypeAllFiles
.LastModified = msoLastModifiedAnyTime
iCount = .Execute
strMessage = Format(iCount, " 0 Files Found")
For Each vaFileName In .FoundFiles
Maxi = Len(vaFileName)
MyNewString = Mid(vaFileName, Mini + 2, Maxi - Mini - 5)
Cells(i, 11).Value = MyNewString
'strMessage = strMessage & vbCr & vaFileName
'Set ImpRng = Cells(i, 1)
On Error Resume Next
'FileName = "H:\MTO-36016\mat\36016-410-32-501-01.mmm"
Open vaFileName For Input As #1
If Err <> 0 Then
MsgBox "Not found: " & FileName, vbCritical, "ERROR"
Exit Sub
End If
r = 0
c = 1
txt = ""
Do Until EOF(1)
Line Input #1, Data
For j = 1 To Len(Data)
Char = Mid(Data, j, 1)
If Char = ";" Then
'MsgBox ("Schrijven")
Cells(i + r, c).Value = txt
c = c + 1
txt = ""
ElseIf j = Len(Data) Then
If Char <> Chr(34) Then txt = txt & Char
'MsgBox ("Char 34")
Cells(i + r, c).Value = txt
txt = ""
ElseIf Char <> Chr(34) Then
txt = txt & Char
End If
Next j
Cells(i + r, 11).Value = MyNewString
c = 1
r = r + 1
Loop
Close #1
i = i + r
Next vaFileName
End With
'Bepalen grootte van de sheet
Range("A1").Select
i = 2
Do While Cells(i, 1).Value <> ""
i = i + 1
Loop
totaal = i - 1
'Voorliggende spaties verwijderen
Range("A1").Select
For i = 2 To totaal
'A=1,C=3,E=5,F=6,H=8,I=9
Cells(i, 1).Value = Trim(Cells(i, 1).Value)
Cells(i, 2).Value = Trim(Cells(i, 2).Value)
Cells(i, 3).Value = Trim(Cells(i, 3).Value)
Cells(i, 4).Value = Trim(Cells(i, 4).Value)
Cells(i, 5).Value = Trim(Cells(i, 5).Value)
'Maak meters van de hoeveelheid voor Pipe elementen en gewichten per meter
Description = Cells(i, 5).Value
If Left(Description, 4) = "Pipe" Then
Cells(i, 2).Value = Cells(i, 2).Value / 1000
End If
Cells(i, 6).Value = Trim(Cells(i, 6).Value)
Cells(i, 7).Value = Trim(Cells(i, 7).Value)
Cells(i, 8).Value = Trim(Cells(i, 8).Value)
Cells(i, 9).Value = Trim(Cells(i, 9).Value)
Cells(i, 10).Value = Trim(Cells(i, 10).Value)
SPEC = Cells(i, 10).Value
If Len(SPEC) = 5 Then
Cells(i, 10).Value = "'0" & SPEC
Else
Cells(i, 10).Value = "'" & SPEC
End If
Next
'Sorteren bestand op NEM-code
range_1 = "A2:K" & totaal
Range(range_1).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Public Sub AddToImportFromLL()
'##############################################
'Openen de data ophalen uit een Access database
'Ophalen data via Jet engine
'Database is LL.MDB
'Tabel is LINELIST
'Database heeft geen beveiliging
'Voor ADODB zijn de volgende verwijzingen (DLL's) in VBA nodig:
'Microsoft ActiveX Data Objects 2.8
'Microsoft Forms 2.0 Object library
'De eerste verwijzing is voor ADODB nodig, de tweede mogelijk voor andere delen van de software.
'Verder verwijzingen die meegenomen zijn:
'Microsoft Access 11.0 Object library
'Microsoft Office 11.0 Object library
'Microsoft ActiveX Data Objects (multi dimensional) 2.8
'Toevoegen Tekeningnummer aan de hand van KKS nummer
'Essentieel d.d. 08-02-2010
'##############################################
Dim objConnDB As ADODB.Connection
Dim objRsDB As ADODB.Recordset
Dim objField As ADODB.Field
Dim sSQL As String
Dim RecordNo As Long
Dim TotalRecords As Long
Dim intColIndex As Integer
'Bepalen aantal records
' Sheets("HANDLEIDING").Select
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 3).Value <> ""
i = i + 1
Loop
numberOfImportRecords = i - 2
'Deze regel is verwijderd vanwege andere manier van lezen mmm files
'Sheets("Import").Cells(1, 11).Value = "Iso tekeningnummer"
Sheets("Import").Cells(1, 12).Value = "NPS"
Sheets("Import").Cells(1, 28).Value = "MDMT"
Application.StatusBar = True
Application.StatusBar = "Copieren tekeningnummers"
' open the database LL
Set TargetRange = Sheets("Import").Cells(1, 11)
database = directoryLL & "\LL.MDB"
'database = "H:\isoextractor\MTO\Kukler\LL.MDB"
Set objConnDB = New ADODB.Connection
objConnDB.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
database & ";"
'Debug.Print objConnDB
For i = 2 To numberOfImportRecords + 1
kksNUM = Sheets("Import").Cells(i, 9).Value
Set objRsDB = New ADODB.Recordset
With objRsDB
' open the recordset
'.Open LINELIST, cn, adOpenStatic, adLockOptimistic, adCmdTable
' all records
'Veld MDMT toegevoegd d.d.30-06-2010
'Deze regel is veranderd vanwege andere manier van lezen mmm files
'.Open "SELECT [DWG_NUM], [NPS], [MDMT] FROM LINELIST" & _
' " WHERE [KKS_NUM] = '" & kksNUM & "'", objConnDB, , , adCmdText
.Open "SELECT [NPS], [MDMT] FROM LINELIST" & _
" WHERE [KKS_NUM] = '" & kksNUM & "'", objConnDB, , , adCmdText
'Deze regel is veranderd vanwege andere manier van lezen mmm files
'Sheets("Import").Cells(i, 11).CopyFromRecordset objRsDB ' the recordset data
Sheets("Import").Cells(i, 12).CopyFromRecordset objRsDB ' the recordset data
End With
Next
'TotalRecords = objRsDB.RecordCount
objRsDB.Close
objConnDB.Close
Set objRsDB = Nothing
Set objConnDB = Nothing
Application.StatusBar = "Einde ophalen LineList gegevens"
'kolom met MDMT verplaatsen in verband met andere ophaalakties die dan niet gewijzigd hoeven te worden
Columns("M:M").Select
'Application.CutCopyMode = False
Selection.Copy
Columns("AB:AB").Select
ActiveSheet.Paste
End Sub
Public Sub AddToImportFromSPECMAT()
'##############################################
'Openen de data ophalen uit een Access database
''Ophalen data via Jet engine
'Database is SPECMAT.MDB
'Tabel is de desbetreffende spec table
'Database heeft geen beveiliging
'Voor ADODB zijn de volgende verwijzingen (DLL's) in VBA nodig:
'Microsoft ActiveX Data Objects 2.8
'Microsoft Forms 2.0 Object library
'De eerste verwijzing is voor ADODB nodig, de tweede mogelijk voor andere delen van de software.
'Verder verwijzingen die meegenomen zijn:
'Microsoft Access 11.0 Object library
'Microsoft Office 11.0 Object library
'Microsoft ActiveX Data Objects (multi dimensional) 2.8
'Toevoegen Tekeningnummer aan de hand van KKS nummer
'##############################################
Dim objConnDB As ADODB.Connection
Dim objRsDB As ADODB.Recordset
Dim objField As ADODB.Field
Dim sSQL As String
Dim RecordNo As Long
Dim TotalRecords As Long
Dim intColIndex As Integer
Dim NEMCode As String
'Bepalen aantal records
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 3).Value <> ""
i = i + 1
Loop
numberOfImportRecords = i - 2
Application.StatusBar = True
Application.StatusBar = "Copieren data van de spec's"
Sheets("Import").Cells(1, 13).Value = "Diameter 1"
Sheets("Import").Cells(1, 14).Value = "Diameter 2"
Sheets("Import").Cells(1, 15).Value = "Schedule"
Sheets("Import").Cells(1, 16).Value = "Rating"
Sheets("Import").Cells(1, 17).Value = "Verwijzing"
Sheets("Import").Cells(1, 18).Value = "Radius"
Sheets("Import").Cells(1, 19).Value = "Spec"
Sheets("Import").Cells(1, 20).Value = "Size"
Sheets("Import").Cells(1, 21).Value = "Prating"
Sheets("Import").Cells(1, 22).Value = "Description"
Sheets("Import").Cells(1, 23).Value = "Weight"
Sheets("Import").Cells(1, 24).Value = "Material"
Sheets("Import").Cells(1, 25).Value = "Key"
Sheets("Import").Cells(1, 27).Value = "Gewicht per mm"
'Sheets("Import").Cells(1, 13).Value = "Diameter 2"
'Sheets("Import").Cells(1, 14).Value = "Schedule"
'Sheets("Import").Cells(1, 15).Value = "Rating"
'Sheets("Import").Cells(1, 16).Value = "Gewicht"
'Sheets("Import").Cells(1, 17).Value = "Key"
' open the database Specmat
Set TargetRange = Sheets("Import").Cells(1, 14)
database = directorySpecmat & "\SPECMAT.MDB"
'database = "M:\NEMLDN_3D_V8\DESIGNSERIES\88888\linelist\SPECMAT.MDB"
Set objConnDB = New ADODB.Connection
objConnDB.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
database & ";"
'Debug.Print objConnDB
For i = 2 To numberOfImportRecords + 1
Diameter = Sheets("Import").Cells(i, 3).Value
Wanddikte = Sheets("Import").Cells(i, 4).Value
omschrijving = Sheets("Import").Cells(i, 5).Value
SPEC = Sheets("Import").Cells(i, 10).Value
If Wanddikte = "" Then
sSQL = "SELECT [DIAMETER1],[DIAMETER2],[SCHEDULE]," & _
" [RATING],[VERWIJZING],[RADIUS]," & _
" [SPEC],[SIZE],[PRATING],[DESCRIPTION]," & _
" [WEIGHT],[MATERIAL] FROM " & SPEC & _
" WHERE [SIZE] = '" & Diameter & "'" & _
" AND [DESCRIPTION] = '" & omschrijving & "'"
Else
sSQL = "SELECT [DIAMETER1],[DIAMETER2],[SCHEDULE]," & _
" [RATING],[VERWIJZING],[RADIUS]," & _
" [SPEC],[SIZE],[PRATING],[DESCRIPTION]," & _
" [WEIGHT],[MATERIAL] FROM " & SPEC & _
" WHERE [SIZE] = '" & Diameter & "'" & _
" AND [PRATING] ='" & Wanddikte & "'" & _
" AND [DESCRIPTION] = '" & omschrijving & "'"
End If
'Debug.Print sSQL
Set objRsDB = New ADODB.Recordset
With objRsDB
' open the recordset
'.Open LINELIST, cn, adOpenStatic, adLockOptimistic, adCmdTable
' all records
.Open sSQL, objConnDB, , , adCmdText
Sheets("Import").Cells(i, 13).CopyFromRecordset objRsDB ' the recordset data
End With
Next
For i = 2 To numberOfImportRecords + 1
Diameter = Sheets("Import").Cells(i, 3).Value
Wanddikte = Sheets("Import").Cells(i, 4).Value
omschrijving = Sheets("Import").Cells(i, 5).Value
diameter2 = Sheets("Import").Cells(i, 14).Value
schedule = Sheets("Import").Cells(i, 15).Value
rating2 = Sheets("Import").Cells(i, 16).Value
gewicht = Sheets("Import").Cells(i, 23).Value
If diameter2 = "" And schedule = "" And rating2 = "" And gewicht = "" Then
If Wanddikte = "" Then
sSQL = "SELECT [DIAMETER1],[DIAMETER2],[SCHEDULE]," & _
" [RATING],[VERWIJZING],[RADIUS]," & _
" [SPEC],[SIZE],[PRATING],[DESCRIPTION], " & _
" [WEIGHT],[MATERIAL] FROM XTRA" & _
" WHERE [SIZE] = '" & Diameter & "'" & _
" AND [DESCRIPTION] = '" & omschrijving & "'"
Else
sSQL = "SELECT [DIAMETER1],[DIAMETER2],[SCHEDULE]," & _
" [RATING],[VERWIJZING],[RADIUS]," & _
" [SPEC],[SIZE],[PRATING],[DESCRIPTION], " & _
" [WEIGHT],[MATERIAL] FROM XTRA" & _
" WHERE [SIZE] = '" & Diameter & "'" & _
" AND [PRATING] ='" & Wanddikte & "'" & _
" AND [DESCRIPTION] = '" & omschrijving & "'"
End If
Set objRsDB = New ADODB.Recordset
With objRsDB
' open the recordset
.Open sSQL, objConnDB, , , adCmdText
Sheets("Import").Cells(i, 13).CopyFromRecordset objRsDB ' the recordset data
End With
End If
Next
objRsDB.Close
objConnDB.Close
Set objRsDB = Nothing
Set objConnDB = Nothing
For i = 2 To numberOfImportRecords + 1
omschrijving = Sheets("Import").Cells(i, 5).Value
gewicht = Sheets("Import").Cells(i, 23).Value
If omschrijving = "Pipe" Then
Sheets("Import").Cells(i, 23).Value = gewicht * 1000
Sheets("Import").Cells(i, 27).Value = gewicht
End If
Next
Application.StatusBar = "Einde ophalen specmat"
End Sub
Sub SheetsTekeningnummersAdd()
'##########################################################
'
' Controle en eventueel aanmaken Import sheet
' H.J.Timmerman d.d. 26-01-2010
'##########################################################
Dim werkblad As Object
Dim aantalBladen As Integer
Dim aanwezig As Boolean
aanwezig = False
aantalBladen = Sheets.Count
For Each werkblad In Sheets
'Debug.Print werkblad.Name
If werkblad.Type = xlWorksheet Then
If werkblad.Name = "Tekeningnummers" Then
aanwezig = True
End If
End If
Next
If Not aanwezig Then
With ActiveWorkbook
.Sheets.Add _
Before:=.Sheets("MTO"), _
Type:=xlWorksheet
End With
ActiveSheet.Name = "Tekeningnummers"
Else
Sheets("Tekeningnummers").Select
Cells.Select
Selection.ClearContents
End If
Sheets("HANDLEIDING").Select
End Sub
Public Sub AddToTekeningnummersFromImport()
'##########################################################
'
' Overhalen KKS-nummers en Iso tekeningnummers van de sheet Import
' naar de sheet Tekeningnummers
' H.J.Timmerman d.d. 02-03-2010
'##########################################################
Sheets("Tekeningnummers").Cells(1, 1).Value = "KKS-code"
Sheets("Tekeningnummers").Cells(1, 2).Value = "ISO-tekeningnummer"
Sheets("Tekeningnummers").Cells(1, 4).Value = "MDMT"
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaal = i - 1
'Deze regel is veranderd, sorteren was op KKS nummer
RANGE_0 = "A2:AB" & totaal 'sorteer range uitgebreid d.d. 04-04-10
Range(RANGE_0).Sort Key1:=Range("K2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
'Range("A1:Y113").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
i = 2
j = 2
For i = 2 To totaal
'MDMT toegevoegd
KKS_nummer1 = Sheets("Import").Cells(i, 9).Value
DWG_NUM1 = Sheets("Import").Cells(i, 11).Value
MDMT = Sheets("Import").Cells(i, 28).Value
Sheets("Tekeningnummers").Cells(j, 1).Value = KKS_nummer1
Sheets("Tekeningnummers").Cells(j, 2).Value = DWG_NUM1
Sheets("Tekeningnummers").Cells(j, 4).Value = MDMT
Do
KKS_nummer1 = Sheets("Import").Cells(i, 9).Value
KKS_nummer2 = Sheets("Import").Cells(i + 1, 9).Value
DWG_NUM1 = Sheets("Import").Cells(i, 11).Value
DWG_NUM2 = Sheets("Import").Cells(i + 1, 11).Value
i = i + 1
'Deze regel veranderd, controle was op KKS nummer
Loop While DWG_NUM1 = DWG_NUM2
i = i - 1
j = j + 1
Next
'Sorteren op iso-tekeningnummers
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 1).Value <> ""
i = i + 1
Loop
totaal = i - 1
Sheets("Tekeningnummers").Select
range_1 = "A1:D" & totaal
Range(range_1).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Public Sub AddToTekeningnummersFromImportRevision()
'##########################################################
'
' Overhalen KKS-nummers en Iso tekeningnummers van de sheet Import
' naar de sheet Tekeningnummers
' H.J.Timmerman d.d. 02-03-2010
'##########################################################
Sheets("Tekeningnummers").Select
Range("A1").Select
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 1).Value <> ""
tekeningNummerLijst(i, 1) = " "
tekeningNummerLijst(i, 2) = " "
tekeningNummerLijst(i, 3) = " "
tekeningNummerLijst(i, 4) = " "
'Debug.Print tekeningNummerLijst(i, 1) & " " & tekeningNummerLijst(i, 2)
i = i + 1
Loop
totaal = i - 1
'Sorteren op tekening nummer
range_1 = "A1:D" & totaal
Range(range_1).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'MDMT toegevoegd
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 2).Value <> ""
tekeningNummerLijst(i, 1) = Sheets("Tekeningnummers").Cells(i, 1).Value 'KKS-code
tekeningNummerLijst(i, 2) = Sheets("Tekeningnummers").Cells(i, 2).Value 'Tekeningnummer
tekeningNummerLijst(i, 4) = Sheets("Tekeningnummers").Cells(i, 4).Value 'MDMT
'Debug.Print tekeningNummerLijst(i, 2)
i = i + 1
Loop
totaalTekeningNummersOud = i - 1
totaalTekeningNummersNieuw = totaalTekeningNummersOud
'Import sorteren op tekening nummer
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaalRecords = i - 1
RANGE_0 = "A2:AB" & totaalRecords
Range(RANGE_0).Sort Key1:=Range("K2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
i = 2
j = 2
aanwezig = False
For i = 2 To totaalRecords
KKS_nummer1 = Sheets("Import").Cells(i, 9).Value
DWG_NUM1 = Sheets("Import").Cells(i, 11).Value
MDMT1 = Sheets("Import").Cells(i, 28).Value
'k = 2
'Do Until tekeningNummerLijst(k, 1) = KKS_nummer1 'And k > totaalTekeningNummersNieuw
' kNum = k
' k = k + 1
' aanwezig = True
'Loop
For k = 2 To totaalTekeningNummersOud
If tekeningNummerLijst(k, 2) = DWG_NUM1 Then
aanwezig = True
kNum = k
End If
Next
If aanwezig Then
Sheets("Tekeningnummers").Cells(kNum, 3).Value = "Bestaand"
Sheets("Tekeningnummers").Cells(kNum, 3).Font.Bold = False
aanwezig = False
Else
totaalTekeningNummersNieuw = totaalTekeningNummersNieuw + 1
kNum = totaalTekeningNummersNieuw
'Sheets("Tekeningnummers").Rows(range_k).Select
'Selection.Insert Shift:=xlDown
Sheets("Tekeningnummers").Cells(kNum, 1).Value = KKS_nummer1
Sheets("Tekeningnummers").Cells(kNum, 1).Font.Bold = True
Sheets("Tekeningnummers").Cells(kNum, 2).Value = DWG_NUM1
Sheets("Tekeningnummers").Cells(kNum, 2).Font.Bold = True
Sheets("Tekeningnummers").Cells(kNum, 3).Value = "Nieuw"
Sheets("Tekeningnummers").Cells(kNum, 3).Font.Bold = True
Sheets("Tekeningnummers").Cells(kNum, 4).Value = MDMT1
Sheets("Tekeningnummers").Cells(kNum, 4).Font.Bold = True
tekeningNummerLijst(kNum, 1) = KKS_nummer1
tekeningNummerLijst(kNum, 2) = DWG_NUM1
tekeningNummerLijst(kNum, 2) = MDMT1
End If
Do
KKS_nummer1 = Sheets("Import").Cells(i, 9).Value
KKS_nummer2 = Sheets("Import").Cells(i + 1, 9).Value
DWG_NUM1 = Sheets("Import").Cells(i, 11).Value
DWG_NUM2 = Sheets("Import").Cells(i + 1, 11).Value
i = i + 1
'Deze regel veranderd, controle was op KKS nummer
Loop While DWG_NUM1 = DWG_NUM2
i = i - 1
j = j + 1
Next
'Sorteren op iso-tekeningnummers
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 1).Value <> ""
i = i + 1
Loop
totaal = i - 1
Sheets("Tekeningnummers").Select
range_1 = "A1:D" & totaal
Range(range_1).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 1).Value <> ""
tekeningNummerLijst(i, 1) = Sheets("Tekeningnummers").Cells(i, 1).Value
tekeningNummerLijst(i, 2) = Sheets("Tekeningnummers").Cells(i, 2).Value
tekeningNummerLijst(i, 3) = Sheets("Tekeningnummers").Cells(i, 3).Value
tekeningNummerLijst(i, 4) = Sheets("Tekeningnummers").Cells(i, 4).Value
'Debug.Print tekeningNummerLijst(i, 1) & " " & tekeningNummerLijst(i, 2) & " " & tekeningNummerLijst(i, 3)
i = i + 1
Loop
End Sub
Public Sub GenImportKey_Click()
'############################################
'Voorziet sheet Import van key t.b.v copieren naar MTO
'd.d. 08-02-2010
'#####################################################
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaal = i - 1
For i = 2 To totaal
omschrijving = Sheets("Import").Cells(i, 5).Value
Diameter = Sheets("Import").Cells(i, 3).Value
Wanddikte = Sheets("Import").Cells(i, 4).Value
material = Sheets("Import").Cells(i, 6).Value
Sheets("Import").Cells(i, 25).Value = omschrijving & "_" & _
Diameter & "_" & Wanddikte & "_" & material
Next
range_1 = "A2:AB" & totaal
Range(range_1).Sort Key1:=Range("Y2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
End Sub
Public Sub ImportOptellen()
'############################################
'Telt de trim-bochten op bij de gewone bochten
'en piping lengtes die twee keer voorkomen in een iso
'd.d. 08-02-2010
'#####################################################
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaal = i - 1
tekeningnummer_1 = Sheets("Import").Cells(2, 11).Value
key_1 = Sheets("Import").Cells(2, 25).Value
hoeveelheid_1 = Sheets("Import").Cells(2, 2).Value
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
tekeningnummer_2 = Sheets("Import").Cells(i + 1, 11).Value
key_2 = Sheets("Import").Cells(i + 1, 25).Value
hoeveelheid_2 = Sheets("Import").Cells(i + 1, 2).Value
If tekeningnummer_1 = tekeningnummer_2 And key_1 = key_2 Then
Sheets("Import").Cells(i, 2).Value = hoeveelheid_1 + hoeveelheid_2
range_d = i + 1 & ":" & i + 1
Rows(range_d).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
tekeningnummer_1 = Sheets("Import").Cells(i + 1, 11).Value
key_1 = Sheets("Import").Cells(i + 1, 25).Value
hoeveelheid_1 = Sheets("Import").Cells(i + 1, 2).Value
i = i + 1
Loop
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaal = i - 1
range_1 = "A2:AB" & totaal
Range(range_1).Sort Key1:=Range("Y2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
End Sub
Public Sub AddToTekeningnummersFromLL()
'Deze wordt niet gebruikt
'##############################################
'Openen de data ophalen uit een Access database
'Ophalen data via Jet engine
'Database is LL.MDB
'Tabel is LINELIST
'Database heeft geen beveiliging
'Voor ADODB zijn de volgende verwijzingen (DLL's) in VBA nodig:
'Microsoft ActiveX Data Objects 2.8
'Microsoft Forms 2.0 Object library
'De eerste verwijzing is voor ADODB nodig, de tweede mogelijk voor andere delen van de software.
'Verder verwijzingen die meegenomen zijn:
'Microsoft Access 11.0 Object library
'Microsoft Office 11.0 Object library
'Microsoft ActiveX Data Objects (multi dimensional) 2.8
'Toevoegen Tekeningnummer aan de hand van KKS nummer
'Essentieel d.d. 08-02-2010
'##############################################
Dim objConnDB As ADODB.Connection
Dim objRsDB As ADODB.Recordset
Dim objField As ADODB.Field
Dim sSQL As String
Dim RecordNo As Long
Dim TotalRecords As Long
Dim intColIndex As Integer
Sheets("Tekeningnummers").Cells(1, 1).Value = "KKS-code"
Sheets("Tekeningnummers").Cells(1, 2).Value = "ISO-tekeningnummer"
Sheets("Tekeningnummers").Cells(1, 4).Value = "MDMT" 'Op verzoek van afdeling per iso toegevoegd
Application.StatusBar = True
Application.StatusBar = "Copieren tekeningnummers"
' open the database LL
database = directoryLL & "\LL.MDB"
'database = "H:\isoextractor\MTO\Kukler\LL.MDB"
Set objConnDB = New ADODB.Connection
objConnDB.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
database & ";"
Set objRsDB = New ADODB.Recordset
With objRsDB
' open the recordset
' all records
'.Open "SELECT [KKS_NUM], [DWG_NUM] FROM LINELIST", objConnDB, , , adCmdText
.Open "SELECT [KKS_NUM], [DWG_NUM], [MDMT] FROM LINELIST" & _
" WHERE [DWG_NUM] <> NULL", objConnDB, , , adCmdText
Sheets("Tekeningnummers").Cells(2, 1).CopyFromRecordset objRsDB ' the recordset data
End With
'Next
objRsDB.Close
objConnDB.Close
Set objRsDB = Nothing
Set objConnDB = Nothing
'Sorteren op iso-tekeningnummers
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 1).Value <> ""
i = i + 1
Loop
totaal = i - 1
Sheets("Tekeningnummers").Select
range_1 = "A1:D" & totaal
Range(range_1).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Application.StatusBar = "Einde ophalen tekeningnummers"
End Sub
Public Sub TekeningnummersToevoegen()
'#######################################
'Tekeningnummers worden vanuit het tabblad Tekeningnummers
'toegvoegd aan het tabblad MTO
'Harm Timmerman d.d. 08-02-2010
'#######################################
Sheets("HANDLEIDING").Select
Range("A1").Select
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 2).Value <> ""
i = i + 1
Loop
totaal = i - 2
numberOfIsoDrawings = totaal
'Kolom met tekeningnummers copieren naar sheet MTO met transpose
'Hiervoor voldoende kolommen invoegen
Sheets("MTO").Select
For i = 1 To totaal Step 1
RANGE_2 = "S:S"
Columns(RANGE_2).Select
Selection.Insert Shift:=xlToRight
Next
Sheets("Tekeningnummers").Select
RANGE_3 = "B2:B" & totaal + 1
Range(RANGE_3).Select
Selection.Copy
Sheets("MTO").Select
Range("S12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'KKS nummers toevoegen
Sheets("Tekeningnummers").Select
RANGE_4 = "A2:A" & totaal + 1
Range(RANGE_4).Select
Selection.Copy
Sheets("MTO").Select
Range("S10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'MDMT nummers toevoegen
Sheets("Tekeningnummers").Select
RANGE_5 = "D2:D" & totaal + 1
Range(RANGE_5).Select
Selection.Copy
Sheets("MTO").Select
Range("S11").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'Range("R12:AA12").Select
'ActiveWorkbook.Names.Add Name:="harm", RefersToR1C1:="=MTO!R12C18:R12C27"
'naamRange = "=MTO!R12C19:R12C" & totaal + 18
'ActiveWorkbook.Names.Add Name:="TekeningenRange", RefersToR1C1:=naamRange
For i = 19 To totaal + 18
Cells(13, i).Value = 1
Next i
End Sub
Public Sub TekeningnummersToevoegenRevision()
'#######################################
'Tekeningnummers worden vanuit het tabblad Tekeningnummers
'toegvoegd aan het tabblad MTO
'Harm Timmerman d.d. 08-02-2010
'#######################################
Sheets("MTO").Select
'MsgBox "Statement in TekenimngnummersToeveogenRevision weghalen"
'Welke tekeningen moeten worden toegevoegd?
'Kolom met tekeningnummers copieren naar sheet MTO met transpose
'Hiervoor voldoende kolommen invoegen
Range("A1").Select
i = 2
Do While Sheets("Tekeningnummers").Cells(i, 2).Value <> ""
If Sheets("Tekeningnummers").Cells(i, 3) = "Nieuw" Then
naam = DubbelAlphabet(i + 17)
Sheets("MTO").Range(naam & ":" & naam).Select
Selection.Insert Shift:=xlToRight
'Tekeningnummer
Sheets("Tekeningnummers").Select
Range("B" & i).Select
Selection.Copy
Sheets("MTO").Select
Range(naam & "12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'KKS nummer
Sheets("Tekeningnummers").Select
Range("A" & i).Select
Selection.Copy
Sheets("MTO").Select
Range(naam & "10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'MDMT
Sheets("Tekeningnummers").Select
Range("D" & i).Select
Selection.Copy
Sheets("MTO").Select
Range(naam & "11").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Range(naam & "13").Select
ActiveCell.Value = 1
End If
i = i + 1
Loop
End Sub
Public Sub DataImportToMTO()
'############################################
'
'###########################################
Dim naamRange As Range
Dim naam As String
Dim formule As String
'Dim kolom As Integer
Sheets("Import").Select
Range("A1").Select
'######################################################
'numberOfIsoDrawings = 25
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
i = 2 'Start line in de import sheet
Do While Cells(i, 5).Value <> "" 'Cells(i,3) veranderd in Cells(i,5) d.d.04-04-10
i = i + 1
Loop
totaal = i - 2
Sheets("MTO").Select
Range("A1").Select
'Set naamRange = Worksheets("MTO").Range(Cells(12, 19), Cells(12, numberOfIsoDrawings))
naam = DubbelAlphabet(numberOfIsoDrawings + 18)
'Debug.Print naam, numberOfIsoDrawings
j = 14 'Start line in de MTO sheet
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> "" 'Cells(i,3) veranderd in Cells(i,5) d.d.04-04-10
Sheets("MTO").Cells(j, 1).Value = Sheets("Import").Cells(i, 23).Value
Sheets("MTO").Cells(j, 3).Value = Sheets("Import").Cells(i, 5).Value
Sheets("MTO").Cells(j, 5).Value = Sheets("Import").Cells(i, 3).Value
Sheets("MTO").Cells(j, 6).Value = Sheets("Import").Cells(i, 4).Value
Sheets("MTO").Cells(j, 7).Value = Sheets("Import").Cells(i, 13).Value 'diameter in inch
Sheets("MTO").Cells(j, 8).Value = Sheets("Import").Cells(i, 15).Value 'schedule
Sheets("MTO").Cells(j, 9).Value = Sheets("Import").Cells(i, 6).Value
Do
tekeningnummer = Sheets("Import").Cells(i, 11).Value
hoeveelheid = Sheets("Import").Cells(i, 2).Value
'MsgBox "Omschrijving = " & Left(Sheets("Import").Cells(i, 5), 7)
With Worksheets("MTO").Range(Cells(12, 19), Cells(12, numberOfIsoDrawings + 18))
Set c = .Find(tekeningnummer, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
'Debug.Print firstAddress
kolomNummer = c.Column
Sheets("MTO").Cells(j, kolomNummer).Value = hoeveelheid
End If
End With
NEMcode1 = Sheets("Import").Cells(i, 25).Value
NEMCode2 = Sheets("Import").Cells(i + 1, 25).Value
Sheets("MTO").Cells(j, 35 + numberOfIsoDrawings).Value = NEMcode1
i = i + 1
Loop While NEMcode1 = NEMCode2
j = j + 1
Loop
End Sub
Public Sub DataImportToMTORevision()
'############################################
'
'###########################################
Dim naamRange As Range
Dim naam As String
Dim formule As String
'Dim kolom As Integer
Sheets("Import").Select
Range("A1").Select
'######################################################
'numberOfIsoDrawings = 25
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
i = 2 'Start line in de import sheet
Do While Cells(i, 5).Value <> "" 'Cells(i,3) veranderd in Cells(i,5) d.d.04-04-10
i = i + 1
Loop
totaalRecordsImport = i - 1
Sheets("MTO").Select
Range("A1").Select
i = 14 'Start line in de MTO sheet
startWaardeTekeningen = 19
'MsgBox "statement verwijderen"
' totaalTekeningNummersOud = 17
' totaalTekeningNummersNieuw = 19
For j = 19 To totaalTekeningNummersNieuw + 17
itemTekening(j) = Sheets("MTO").Cells(12, j).Value
'Debug.Print itemTekening(j)
Next
Do While Cells(i, 5).Value <> ""
itemCode(i) = Cells(i, totaalTekeningNummersNieuw + 34).Value
'Debug.Print itemCode(i)
For j = 19 To totaalTekeningNummersNieuw + 17
itemAantal(i, j) = Sheets("MTO").Cells(i, j).Value
'Debug.Print "i= " & i & "j = " & j & " aantal= " & itemAantal(i, j)
Next
i = i + 1
Loop
totaalRecordsMTO = i - 14
totaalRecordsMTONieuw = totaalRecordsMTO
j = 14
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
Weight = Sheets("Import").Cells(i, 23).Value
Description = Sheets("Import").Cells(i, 5).Value
Diameter = Sheets("Import").Cells(i, 3).Value
Wanddikte = Sheets("Import").Cells(i, 4).Value
Materiaal = Sheets("Import").Cells(i, 6).Value
tekeningnummer = Sheets("Import").Cells(i, 11).Value
hoeveelheid = Sheets("Import").Cells(i, 2).Value
Key = Sheets("Import").Cells(i, 25).Value
k = 19
tekNum = k
Do While tekeningnummer <> itemTekening(k) And k < totaalTekeningNummersNieuw + 17
k = k + 1
tekNum = k
'Debug.Print "k= " & k & " " & itemTekening(k)
'Debug.Print "tekNum= " & tekNum
Loop
'gevonden = True
m = 14
codeNum = m
Do While Key <> itemCode(m) And m < totaalRecordsMTONieuw + 14
'gevonden = False
m = m + 1
codeNum = m
'Debug.Print "m= " & m & " " & itemCode(m)
Loop
If codeNum < totaalRecordsMTONieuw + 14 Then
'gevonden = True
If hoeveelheid <> itemAantal(m, tekNum) Then
Sheets("MTO").Cells(m, tekNum).Value = hoeveelheid
Sheets("MTO").Cells(m, tekNum).Font.Bold = True
End If
Else
'gevonden = False
totaalRecordsMTONieuw = totaalRecordsMTONieuw + 1
Sheets("MTO").Cells(codeNum, totaalTekeningNummersNieuw + 34).Value = Key
Sheets("MTO").Cells(codeNum, totaalTekeningNummersNieuw + 34).Font.Bold = True
Sheets("MTO").Cells(codeNum, tekNum).Value = hoeveelheid
Sheets("MTO").Cells(codeNum, tekNum).Font.Bold = True
Sheets("MTO").Cells(codeNum, 1).Value = Weight
Sheets("MTO").Cells(codeNum, 1).Font.Bold = True
Sheets("MTO").Cells(codeNum, 3).Value = Description
Sheets("MTO").Cells(codeNum, 3).Font.Bold = True
Sheets("MTO").Cells(codeNum, 5).Value = Diameter
Sheets("MTO").Cells(codeNum, 5).Font.Bold = True
Sheets("MTO").Cells(codeNum, 6).Value = Wanddikte
Sheets("MTO").Cells(codeNum, 6).Font.Bold = True
Sheets("MTO").Cells(codeNum, 9).Value = Materiaal
Sheets("MTO").Cells(codeNum, 9).Font.Bold = True
itemCode(codeNum) = Key
itemAantal(codeNum, tekNum) = hoeveelheid
End If
'Debug.Print "codeNum= " & codeNum
'If gevonden Then
' If hoeveelheid <> itemAantal(m, tekNum) Then
' Sheets("MTO").Cells(m, tekNum).Value = hoeveelheid
' Sheets("MTO").Cells(m, tekNum).Font.Bold = True
' End If
'End If
'If Not gevonden Then
' totaalRecordsMTONieuw = totaalRecordsMTONieuw + 1
' Sheets("MTO").Cells(codeNum, totaalTekeningNummersNieuw + 34).Value = Key
' Sheets("MTO").Cells(codeNum, totaalTekeningNummersNieuw + 34).Font.Bold = True
' Sheets("MTO").Cells(codeNum, tekNum).Value = hoeveelheid
' Sheets("MTO").Cells(codeNum, tekNum).Font.Bold = True
' Sheets("MTO").Cells(codeNum, 1).Value = Weight
' Sheets("MTO").Cells(codeNum, 1).Font.Bold = True
' Sheets("MTO").Cells(codeNum, 3).Value = Description
' Sheets("MTO").Cells(codeNum, 3).Font.Bold = True
' Sheets("MTO").Cells(codeNum, 5).Value = Diameter
' Sheets("MTO").Cells(codeNum, 5).Font.Bold = True
' Sheets("MTO").Cells(codeNum, 6).Value = Wanddikte
' Sheets("MTO").Cells(codeNum, 6).Font.Bold = True
' Sheets("MTO").Cells(codeNum, 9).Value = Materiaal
' Sheets("MTO").Cells(codeNum, 9).Font.Bold = True
' itemCode(codeNum) = Key
' itemAantal(codeNum, tekNum) = hoeveelheid
'End If
i = i + 1
Loop
End Sub
Sub Aanroep()
Dim num As Integer
num = 10
waarde = Alphabet(num)
'Debug.Print "waarde " & num & " " & waarde
waarde = DubbelAlphabet(num)
'Debug.Print "waarde " & num & " " & waarde
waarde = DubbelAlphabet(num + 26)
'Debug.Print "waarde " & num & " " & waarde
waarde = DubbelAlphabet(num + 26 + 26)
'Debug.Print "waarde " & num & " " & waarde
End Sub
Public Function DubbelAlphabet(num As Integer)
Dim een As Integer
Dim twee As Integer
Dim woord As String
een = num \ 26
twee = num Mod 26
If een = 0 Then
DubbelAlphabet = Alphabet(twee)
Else
DubbelAlphabet = Alphabet(een) & Alphabet(twee)
End If
End Function
Public Function Alphabet(num As Integer)
Dim letter As String
letter = Switch(num = 1, "A", num = 2, "B", num = 3, "C", num = 4, "D", _
num = 5, "E", num = 6, "F", num = 7, "G", num = 8, "H", num = 9, "I", _
num = 10, "J", num = 11, "K", num = 12, "L", num = 13, "M", num = 14, "N", _
num = 15, "O", num = 16, "P", num = 17, "Q", num = 18, "R", _
num = 19, "S", num = 20, "T", num = 21, "U", num = 22, "V", _
num = 23, "W", num = 24, "X", num = 25, "Y", num = 26, "Z")
Alphabet = letter
End Function
Public Sub CompareMTO()
'############################################
'Voorziet sheet Import van key t.b.v copieren naar MTO
'd.d. 08-02-2010
'#####################################################
j = 14 'Start row
Sheets("Import").Select
Range("A1").Select
i = 2
Do While Sheets("Import").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaal1 = i - 1
Sheets("Import(2)").Select
Range("A1").Select
i = 2
Do While Sheets("Import(2)").Cells(i, 5).Value <> ""
i = i + 1
Loop
totaal2 = i - 1
For i = 2 To totaal1
omschrijving = Sheets("Import").Cells(i, 5).Value
Diameter = Sheets("Import").Cells(i, 3).Value
Wanddikte = Sheets("Import").Cells(i, 4).Value
SPEC = Sheets("Import").Cells(i, 10).Value
Sheets("Import").Cells(i, 25).Value = omschrijving & "_" & _
Diameter & "_" & Wanddikte & "_" & SPEC
Next
range_1 = "A2:AB" & totaal
Range(range_1).Sort Key1:=Range("Y2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
End Sub
Sub MTOUpdate()
'
' Macro4 Macro
' De macro is opgenomen op 30-6-2010 door Timmerman.
'
'
Sheets("Import").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Tekeningnummers").Select
ActiveWindow.SelectedSheets.Delete
Sheets("MTO").Select
ActiveWindow.SelectedSheets.Delete
Sheets("MTO (2)").Select
Sheets("MTO (2)").Copy Before:=Sheets(3)
Sheets("MTO (3)").Select
Sheets("MTO (3)").Name = "MTO"
End Sub
Public Sub ReadDirectoryMmmFiles()
Dim FS As Office.FileSearch
Dim strPath As String
Dim vaFileName As Variant
Dim strMessage As String
Dim i As Long
Dim iCount As Long
Sheets("Files").Select
Range("L2").Select
Cells(1, 11).Value = "Filename"
i = 2
Set FS = Application.FileSearch
strPath = Sheets("MTO").Cells(3, 14).Value
Mini = Len(strPath)
With FS
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileName = "*.mmm"
.FileType = msoFileTypeAllFiles
.LastModified = msoLastModifiedAnyTime
iCount = .Execute
strMessage = Format(iCount, " 0 Files Found")
For Each vaFileName In .FoundFiles
Maxi = Len(vaFileName)
MyNewString = Mid(vaFileName, Mini + 2, Maxi - Mini - 5)
Cells(i, 11).Value = MyNewString
'strMessage = strMessage & vbCr & vaFileName
i = i + 1
Next vaFileName
End With
End Sub
Public Sub CopyMmmFiles()
Dim FS As Office.FileSearch
Dim strPath As String
Dim vaFileName As Variant
Dim strMessage As String
Dim i As Long
Dim iCount As Long
Dim ImpRng As Range
Dim FileName As String
Dim r As Long
Dim c As Integer
Dim txt As String
Dim Char As String * 1
Dim Data
Dim j As Integer
Sheets("Files").Select
Range("L2").Select
'######################################################
' Header information
'######################################################
Cells(1, 1).Value = "NEM-code"
Cells(1, 2).Value = "Hoeveelheid"
Cells(1, 3).Value = "Diameter"
Cells(1, 4).Value = "Wanddikte"
Cells(1, 5).Value = "Omschrijving"
Cells(1, 6).Value = "Materiaal"
Cells(1, 7).Value = "Gewicht"
Cells(1, 8).Value = "Shop/Field"
Cells(1, 9).Value = "KKS-nummer"
Cells(1, 10).Value = "Spec"
Cells(1, 11).Value = "ISO-number"
i = 2
Set FS = Application.FileSearch
strPath = Sheets("MTO").Cells(3, 14).Value
Mini = Len(strPath)
With FS
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileName = "*.mmm"
.FileType = msoFileTypeAllFiles
.LastModified = msoLastModifiedAnyTime
iCount = .Execute
strMessage = Format(iCount, " 0 Files Found")
For Each vaFileName In .FoundFiles
Maxi = Len(vaFileName)
MyNewString = Mid(vaFileName, Mini + 2, Maxi - Mini - 5)
Cells(i, 11).Value = MyNewString
'strMessage = strMessage & vbCr & vaFileName
'Set ImpRng = Cells(i, 1)
On Error Resume Next
'FileName = "H:\MTO-36016\mat\36016-410-32-501-01.mmm"
Open vaFileName For Input As #1
If Err <> 0 Then
MsgBox "Not found: " & FileName, vbCritical, "ERROR"
Exit Sub
End If
r = 0
c = 1
txt = ""
Do Until EOF(1)
Line Input #1, Data
For j = 1 To Len(Data)
Char = Mid(Data, j, 1)
If Char = ";" Then
'MsgBox ("Schrijven")
Cells(i + r, c).Value = txt
c = c + 1
txt = ""
ElseIf j = Len(Data) Then
If Char <> Chr(34) Then txt = txt & Char
'MsgBox ("Char 34")
Cells(i + r, c).Value = txt
txt = ""
ElseIf Char <> Chr(34) Then
txt = txt & Char
End If
Next j
Cells(i + r, 11).Value = MyNewString
c = 1
r = r + 1
Loop
Close #1
i = i + r
Next vaFileName
End With
'Bepalen grootte van de sheet
Range("A1").Select
i = 2
Do While Cells(i, 1).Value <> ""
i = i + 1
Loop
totaal = i - 1
'Voorliggende spaties verwijderen
Range("A1").Select
For i = 2 To totaal
'A=1,C=3,E=5,F=6,H=8,I=9
Cells(i, 1).Value = Trim(Cells(i, 1).Value)
Cells(i, 2).Value = Trim(Cells(i, 2).Value)
Cells(i, 3).Value = Trim(Cells(i, 3).Value)
Cells(i, 4).Value = Trim(Cells(i, 4).Value)
Cells(i, 5).Value = Trim(Cells(i, 5).Value)
'Maak meters van de hoeveelheid voor Pipe elementen en gewichten per meter
Description = Cells(i, 5).Value
If Left(Description, 4) = "Pipe" Then
Cells(i, 2).Value = Cells(i, 2).Value / 1000
End If
Cells(i, 6).Value = Trim(Cells(i, 6).Value)
Cells(i, 7).Value = Trim(Cells(i, 7).Value)
Cells(i, 8).Value = Trim(Cells(i, 8).Value)
Cells(i, 9).Value = Trim(Cells(i, 9).Value)
Cells(i, 10).Value = Trim(Cells(i, 10).Value)
SPEC = Cells(i, 10).Value
If Len(SPEC) = 5 Then
Cells(i, 10).Value = "'0" & SPEC
Else
Cells(i, 10).Value = "'" & SPEC
End If
Next
'Sorteren bestand op NEM-code
range_1 = "A2:K" & totaal
Range(range_1).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Read the content of the *.mmm files and put them into the excel sheet.
Sub ImportRange()
Dim ImpRng As Range
Dim FileName As String
Dim r As Long
Dim c As Integer
Dim txt As String
Dim Char As String * 1
Dim Data
Dim j As Integer
Sheets("Files").Select
Range("A2").Select
Set ImpRng = ActiveCell
On Error Resume Next
FileName = "H:\MTO-36016\mat\36016-410-32-501-01.mmm"
Open FileName For Input As #1
If Err <> 0 Then
MsgBox "Not found: " & FileName, vbCritical, "ERROR"
Exit Sub
End If
r = 0
c = 0
txt = ""
Do Until EOF(1)
Line Input #1, Data
For j = 1 To Len(Data)
Char = Mid(Data, j, 1)
If Char = ";" Then
'MsgBox ("Schrijven")
ActiveCell.Offset(r, c) = txt
c = c + 1
txt = ""
ElseIf j = Len(Data) Then
If Char <> Chr(34) Then txt = txt & Char
MsgBox ("Char 34")
ActiveCell.Offset(r, c) = txt
txt = ""
ElseIf Char <> Chr(34) Then
txt = txt & Char
End If
Next j
c = 0
r = r + 1
Loop
Close #1
End Sub
Check, Delete and sometimes create a filesheet
Sub SheetsFilesAdd()
Dim werkblad As Object
Dim aantalBladen As Integer
Dim aanwezig As Boolean
aanwezig = False
aantalBladen = Sheets.Count
For Each werkblad In Sheets
'Debug.Print werkblad.Name
If werkblad.Type = xlWorksheet Then
If werkblad.Name = "Files" Then
aanwezig = True
End If
End If
Next
If Not aanwezig Then
With ActiveWorkbook
.Sheets.Add _
Before:=.Sheets("MTO"), _
Type:=xlWorksheet
End With
ActiveSheet.Name = "Files"
Else
Sheets("Files").Select
Cells.Select
Selection.ClearContents
End If
Sheets("Files").Select
Module 3.
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 6-7-2010 by htimmerman
'
'
Range("A1:Y113").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Much thanks in advance, we really need this asap!
Jesper
Last edited:
