I recently inherited this data base from the DBManger who quit, I was the data entry person, now the acting manager. The first half, in Blue, strips an Excel file and reconfigures it. That part works great. The second half imports it into the Access table. It works with files that are less than 13000 lines but I keep getting different errors or it just cuts that data off when importing a 16000 line file at around line 14500. The Excell sheet looks good and is stripped out correctly. I thought the line in red was the problem but that is just a comment so it should have no bearing.
Private Sub CmdBOMImport_Click()
On Error GoTo Err_CmdBOMImport_Click
DoCmd.SetWarnings False
Call ImportBOMs
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryBOM_Blanks"
DoCmd.OpenQuery "qryBOM_RevUpdate"
DoCmd.SetWarnings True
MsgBox "BOM Import Complete", vbOKOnly, "All Done"
Exit_CmdBOMImport_Click:
Exit Sub
Err_CmdBOMImport_Click:
MsgBox Err.Description
Resume Exit_CmdBOMImport_Click
End Sub
Public Sub ImportBOMs()
DoCmd.SetWarnings False
Dim strSQL As String
Dim strFilter As String
Dim strInputFileName As String
Dim Msg As String
'Open file dialog box to choose file to import
strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
strInputFileName = ahtCommonFileOpenSave( _
Filter:=strFilter, OpenFile:=True, _
DialogTitle:="Please select an input file...", _
Flags:=ahtOFN_HIDEREADONLY)
'Clean up selected Bom for import
'Formly known as BOMLgFormat()in Excel
' Msg = "Assumes the initial excel format data in these locations: [tobe] indicates new location after subprogram" & (Chr(13)) & _
'"BOM Sort - Column A BOM Sort Sequence stating at 0" & (Chr(13)) & _
'"Level - Column B BOM Indent Level" & (Chr(13)) & _
'"Find Number - Column D [tobe C] Drawing Find Number" & (Chr(13)) & _
'"Part Number - Column G [tobe D] Component Past Number" & (Chr(13)) & _
'"Description - Column H [tobe E]" & (Chr(13)) & _
'"Rev - A11 [tobe F2]" & (Chr(13)) & _
'"Quantity (per) - Column K [tobe G]" & (Chr(13)) & _
'"Cage Code - Column L [tobe H]" & (Chr(13)) & _
'"Lead Time - Column M [tobe I]" & (Chr(13)) & _
'"Design Date - Column T [tobe J]" & (Chr(13)) & _
'"Next Higher Assy NHA - A10 [tobe K]" & (Chr(13)) & _
'"Designation - G10 [tobe L]" & (Chr(13)) & _
' MsgBox Msg, vbOKOnly, "Check Format"
Dim xlApp As Excel.Application
Dim xlBook As Object
Dim xlSheet As Object
Dim i As Long
Dim LastRow As Long
Dim line As Long
Dim b As Object
Dim Lrow As Long
Dim Acell As Object
'Open Excel & Open the file so we can play with it
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Open(strInputFileName)
Set xlSheet = xlApp.ActiveWorkbook.Worksheets(1)
xlApp.Visible = True
'Make the top level part number level 0 part number
With xlSheet.Application
xlSheet.Rows(13).EntireRow.Insert
' xlSheet.Rows("13:13").Select
' xlSheet.ActiveCell.EntireRow.Insert
' xlSheet.Selection.Insert Shift:=xlSheet.xlDown, CopyOrigin:=xlSheet.xlFormatFromLeftOrAbove
' xlSheet.Range("13:13").Select
'xlSheet.Range("A:13").Activate
'xlSheet.Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
xlSheet.Range("A13").value = 0
xlSheet.Range("B13").Select
xlSheet.Range("B13").FormulaR1C1 = 0
' xlSheet.Range("G13").Select
xlSheet.Range("G13").FormulaR1C1 = "=TRIM(RIGHT(R[-8]C[-6],14))"
' xlSheet.Range("H13").Select
xlSheet.Range("H13").FormulaR1C1 = _
"=TRIM(MID(R[-3]C[-1],FIND("":"",R[-3]C[-1],1)+1,250))"
xlSheet.Range("I13").Select
xlSheet.Range("I13").FormulaR1C1 = "=RIGHT(R[-2]C[-8],1)"
' xlSheet.Range("K13").Select
xlSheet.Range("K13").FormulaR1C1 = "1"
' xlSheet.Rows("13:13").Select
xlSheet.Range("13:13").Copy
xlSheet.Range("13:13").PasteSpecial Paste:=xlPasteValues
'xlSheet.Range("1:11").Select
' xlSheet.Range("X1").Activate
' xlSheet.Application.CutCopyMode = False
xlSheet.Range("1:11").Delete Shift:=xlUp
'Get rid of the unwanted columns
'xlSheet.Range("C:C,E:F,J:J,N:S,U:W").Select
'xlSheet.Range("U1").Activate
xlSheet.Range("C:C,E:F,J:J,N:S,U:W").EntireColumn. Delete xlShiftToLeft
' xlSheet.Rows(13).EntireRow.Insert
'xlSheet.Columns("C:C,E:F,J:J,N:S,U:W").EntireColu mn.Delete Shift:=xlSheet.xlToLeft
'Format Columns
xlSheet.Columns("H:H").NumberFormat = "@"
xlSheet.Columns("J:J").NumberFormat = "m/d/yyyy"
xlSheet.Columns("I:I").NumberFormat = "0"
xlSheet.Columns("C:C").NumberFormat = "@"
xlSheet.Columns("A:A").NumberFormat = "0"
'Insert column label (field names)
xlSheet.Cells(1, 1).Activate
xlSheet.Columns("A:A").Select
xlSheet.Cells(1, 1).value = "BOM"
xlSheet.Cells(1, 2).value = "Level"
xlSheet.Cells(1, 3).value = "FN"
xlSheet.Cells(1, 4).value = "Component Part"
xlSheet.Cells(1, 5).value = "Component Description"
xlSheet.Cells(1, 6).value = "Rev"
xlSheet.Cells(1, 7).value = "Qty"
xlSheet.Cells(1, 8).value = "Cage Code"
xlSheet.Cells(1, 9).value = "Lead Time"
xlSheet.Cells(1, 10).value = "Design Date"
xlSheet.Cells(1, 11).value = "NHA"
xlSheet.Cells(1, 12).value = "Designation"
'For Each Acell In Selection
' Acell.value = CDec(Acell.value)
' Next Acell
' assign values to the variables - where does the data end?
Lrow = xlSheet.Range("b" & xlSheet.Rows.Count).End(xlUp + 1).Row
LastRow = xlSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
i = 3
line = 0
xlSheet.Range("A1:Z" & LastRow).MergeCells = False
xlSheet.Columns("B:B").SpecialCells(xlCellTypeBlan ks).EntireRow.Delete
xlSheet.Columns("M:XFD").EntireColumn.Delete
xlSheet.Rows(Lrow & ":1048576").EntireRow.Delete
xlSheet.Range("B3:B" & LastRow) = xlSheet.Range("B3:B" & LastRow).value
xlSheet.Cells(3, 12).FormulaR1C1 = "=IF(RC[-10]=1,RC[-7],R[-1]C)"
Dim RngFormula As Range
xlSheet.Range("L3:L" & LastRow).FillDown
' xlSheet.Selection.FillDown
'Next Higher Assembly - looks at level and determines if current level is lower, higher, or equal to the line above it and records the NHA part number
While i < LastRow
Line1:
line = line + 1
For Each b In xlSheet.Cells.CurrentRegion 'ActiveCell.CurrentRegion.Cells
If xlSheet.Cells(i - line, 2).value < xlSheet.Cells(i, 2).value Then
xlSheet.Cells(i, 11).value = xlSheet.Cells(i - line, 4)
ElseIf xlSheet.Cells(i - line, 2).value > xlSheet.Cells(i, 2).value Then
GoTo Line1
Else
xlSheet.Cells(i, 11).value = xlSheet.Cells(i - line, 11).value
End If
If i = LastRow Or i > LastRow Then
Exit For
Else
i = i + 1
End If
line = 1
xlSheet.Cells(i, 2).Activate
Next
Wend
'Autofit the cells
xlSheet.Columns("A:L").Select
'xlSheet.Range("G4524").Activate
xlSheet.Columns("A:L").EntireColumn.AutoFit
'Populate the designation field/column populates with the level 0 part description for piece parts
' xlSheet.Range("E2").Select
' xlSheet.Range("E2").FormulaR1C1 = "=IF(RC[-8]=1,RC[-4],R[-1]C)"
' xlSheet.Selection.AutoFill Destination:=xlSheet.Range("L3:L" & Lrow), Type:=xlFillDefault
' xlSheet.Range("A1").Select
End With
xlBook.Save
xlBook.Close False
xlApp.Quit
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
'Transfer data from selected worksheet to tblBOM
DoCmd.TransferSpreadsheet acImport, , "tblBOM", strInputFileName, -1
'SQL statement to update "vehicle" to name put in field on BOM upload form
strSQL = "UPDATE tblBOM " _
& "SET tblBOM.Vehicle = '" & [Forms]![frmBOMUpload]![txtOBV] & "'" _
& "WHERE (((tblBOM.Vehicle)is null))OR (((tblBOM.Vehicle)=""""));"
DoCmd.SetWarnings False
'Run the update query to populate the vehicle "name" for the newly uploaded records
DoCmd.RunSQL strSQL
'turn off warnings (back on when done) and run the query that populates the "tblADPML_ManualData" table with new records needing completion.
DoCmd.SetWarnings False
'DoCmd.OpenQuery "qryUpdateCompTypeBOM"
'insert query to update blank Rev to N/A
' DoCmd.OpenQuery "qryADPML_Manual"
' DoCmd.OpenQuery "qryADPML_Manual_Specific"
' DoCmd.OpenQuery "qryADPML_Common_Manual"
'DoCmd.OpenForm "frmBOMEntry"
DoCmd.SetWarnings True
' Clean up
End Sub