VBA error when using 2007 instead of 2003

J

Jjesper

New Member
Joined
Jul 12, 2010
Messages
12
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.
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
Click to expand...
Module 2.
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
Click to expand...



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
Click to expand...


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
Click to expand...


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
Click to expand...

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
Click to expand...



Much thanks in advance, we really need this asap!

Jesper
 
Last edited:
Sort by date Sort by votes

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Andrew Poulsom said:
I don't have time to read or amend all your code. Which bit in particular would you like amended?
Click to expand...

Well, only the Application.FileSearch is the one which isn't working with 2007, so that is the only part,
You can see it like 7 times, but 5 are almost identical.

These 3 are maybe the most important, all 3 the same except for the msgboxes and extensions:

Code: 
    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

Then i have this one:
to open a csv file.

Code: 
    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

another one, also more difficult than the first 3

Code: 
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

This one might be the hardest, and im having alot of trouble with it.
Code: 
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
 
Upvote 0
Andrew Poulsom said:
I don't have time to read or amend all your code. Which bit in particular would you like amended?
Click to expand...

Andrew, first of all, thanks a lot!

I tried to amend some code from my previous post,
I used static location in the amended codes below, because i don't know how to get it to work with this code below (it has to fetch the directory of a file from a cell which i put in, so it is dynamic) (might be simple?)
Code: 
    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

This is the amended code from the first code-box:

Code: 
    Dim strPath As String
    Dim strFileName As String
 
    strPath = "K:\DESIGN\36016\EXTRACT ISO\MATERIALEN\"
    strFileName = Dir(strPath & "/" & "*.mmm")
 
    Do While Len(strFileName) > 0
        'ProcessData strFileName
        strFileName = Dir
    Loop
                Exit Sub
 
    'Testen of Linelist aanwezig zijn.
    Dim directoryLLName As String
 
    directoryLL = "K:\DESIGN\36016\EXTRACT ISO\MATERIALEN\"
    directoryLLName = Dir(directoryLL & "/" & "LL.mdb")
 
        Do While Len(directoryLLName) > 0
        'ProcessData directoryLLName
        directoryLLName = Dir
    Loop
 
                Exit Sub
    'Testen of Linelist aanwezig zijn.
    Dim directorySpecmatName As String
 
    directorySpecmat = "K:\DESIGN\36016\EXTRACT ISO\MATERIALEN\"
    directorySpecmatName = Dir(directorySpecmat & "/" & "SPECMAT.mdb")
 
    Do While Len(directorySpecmatName) > 0
        'ProcessData directorySpecmatName
        directorySpecmatName = Dir
    Loop
                Exit Sub

and from the second code-box
Code: 
    Dim directoryFileName As String
 
    directory = "K:\DESIGN\36016\EXTRACT ISO\MATERIALEN\"
    directoryFileName = Dir(directory & "/" & "MATERIAL.csv")
 
    Do While Len(directoryFileName) > 0
        'ProcessData strFileName
        directoryFileName = Dir
    Loop
                Exit Sub




It feels like im forgetting some code, for ex. the SortOrder and etc.
Could you tell me if these amended codes will do exactly the same?

The third and fourth code-box are too difficult, I keep getting errors...
Please help me, thank you!
 
Last edited:
Upvote 0
For your final piece of code try:

Rich (BB code): 
i = 2
'Set FS = Application.FileSearch
strPath = Sheets("MTO").Cells(3, 14).Value
'Mini = Len(strPath)
vaFileName = Dir(strPath & "/" & "*.mmm")
'    With FS
'        .NewSearch
'        .LookIn = strPath
'        .SearchSubFolders = False
'        .FileName = "*.mmm"
'        .FileType = msoFileTypeAllFiles
'        .LastModified = msoLastModifiedAnyTime
'        iCount = .Execute
'        strMessage = Format(iCount, " 0 Files Found")
        Do While vaFileName <> ""
'        For Each vaFileName In .FoundFiles
'            Maxi = Len(vaFileName)
'            MyNewString = Mid(vaFileName, Mini + 2, Maxi - Mini - 5)
            Cells(i, 11).Value = vaFileName
'            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 strPath & "/" & vaFileName For Input As #1
'            Open vaFileName For Input As #1
            If Err <> 0 Then
                MsgBox "Not found:  " & vaFileName, 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 = vaFileName
'                Cells(i + r, 11).Value = MyNewString
                c = 1
                r = r + 1
            Loop
            Close #1
            i = i + r
        Loop
'        Next vaFileName
'    End With
End Sub

I have commented out the bits you don't need and have added the bits in red.

Obviously I can't test it.
 
Upvote 0
Andrew Poulsom said:
For your final piece of code try:

Rich (BB code): 
i = 2
'Set FS = Application.FileSearch
strPath = Sheets("MTO").Cells(3, 14).Value
'Mini = Len(strPath)
vaFileName = Dir(strPath & "/" & "*.mmm")
'    With FS
'        .NewSearch
'        .LookIn = strPath
'        .SearchSubFolders = False
'        .FileName = "*.mmm"
'        .FileType = msoFileTypeAllFiles
'        .LastModified = msoLastModifiedAnyTime
'        iCount = .Execute
'        strMessage = Format(iCount, " 0 Files Found")
     Do While vaFileName <> ""
'        For Each vaFileName In .FoundFiles
'            Maxi = Len(vaFileName)
'            MyNewString = Mid(vaFileName, Mini + 2, Maxi - Mini - 5)
         Cells(i, 11).Value = vaFileName
'            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 strPath & "/" & vaFileName For Input As #1
'            Open vaFileName For Input As #1
            If Err <> 0 Then
                MsgBox "Not found:  " & vaFileName, 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 = vaFileName
'                Cells(i + r, 11).Value = MyNewString
                c = 1
                r = r + 1
            Loop
            Close #1
            i = i + r
     Loop
'        Next vaFileName
'    End With
End Sub

I have commented out the bits you don't need and have added the bits in red.

Obviously I can't test it.
Click to expand...

Ill test them out now,
Are the parts i amended correctly amended?


EDIT: When I'm running the macro, i get the error: Subscript out of range (Run time error 9)
This is not correct according to VB: Sheets("Files").Select

Weird, because when nothing was changed it never gave this error, Have i forgot something?
 
Last edited:
Upvote 0
Well, we got it working, thanks for the piece you amended, we changed it a little bit to make it work for us, because it didn't pick all files from the dir, but only the first one every time.

Big thanks! We made it before the deadline!
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Macro to speedy up process when copying Data
Replies
3
Views
59
Logit
Logit
J
  • Solved
Copy /past cells by inputbox on sheet 2 to sheet1 using VBA
2
Replies
12
Views
394
DanteAmor
DanteAmor
D
  • Solved
Error 1004
2
Replies
18
Views
276
dmt32
D
B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
245
smozgur
smozgur
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
315
RoryA
RoryA

Forum statistics

Threads
1,223,227
Messages
6,170,849
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top