Sub Butt*******()
LargeFileImport
Text_to_Column
Transfer_Data
End Sub
Sub LargeFileImport()
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
'Ask User for File's Name
FileName = ThisWorkbook.Path & "\" & InputBox("Please enter the Text File's name, e.g. test.txt") & ".txt"
'Check for no entry
If FileName = "" Then End
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileName For Input As #FileNum
'Turn Screen Updating Off
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim mypath As String
mypath = ThisWorkbook.Path
'Create A New WorkBook With One Worksheet In It
Workbooks.Add template:=xlWorksheet
ActiveWorkbook.SaveAs (mypath & "/PriceFile.xls")
Application.DisplayAlerts = True
'Set The Counter to 1
Counter = 1
'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)
'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName
'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr
'Store Variable Data Into Active Cell
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "'" & ResultStr
Else
ActiveCell.Value = ResultStr
End If
'For Excel versions before Excel 97, change 65536 to 16384
If ActiveCell.Row = 65536 Then
'If On The Last Row Then Add A New Sheet
ActiveWorkbook.Sheets.Add After:=ActiveSheet
Else
'If Not The Last Row Then Go One Cell Down
ActiveCell.Offset(1, 0).Select
End If
'Increment the Counter By 1
Counter = Counter + 1
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
'Remove Message From Status Bar
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub Text_to_Column()
Application.ScreenUpdating = False
Workbooks("PriceFile").Activate
Dim LastRow As Long
Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
With ws
.Range("A:A").TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
LastRow = .Cells.Find(What:="*", _
searchdirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
.Range("I1:I" & LastRow).FormulaR1C1 = "=ISERROR(SEARCH(LEFT(RC[-8],1),""1234567890"",1))"
Application.CutCopyMode = False
End With
Next ws
Application.ScreenUpdating = True
End Sub
Sub Transfer_Data()
'Add New Workbook
Workbooks.Add template:=xlWorksheet
Dim mypath As String
mypath = ThisWorkbook.Path
'Add New Sheet
ActiveWorkbook.Sheets.Add
ActiveWorkbook.SaveAs (mypath & "/ImportFile.xls")
'Name Sheets
Sheets("Sheet1").Name = "Tyres"
Sheets("Sheet2").Name = "Mechanical"
Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
With ws
.Range("A1").FormulaR1C1 = "=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-5)"
.Range("B1").FormulaR1C1 = "=today()"
.Range("B1").Select
.Range("B1").Copy
.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Application.Goto Reference:="R1C1"
.Application.CutCopyMode = False
.Range("A2").Value = "CODE"
.Range("B2").Value = "DESCRIPTION"
.Range("C2").Value = "XXX"
.Range("D2").Value = "XXX"
.Range("E2").Value = "XXX"
.Range("F2").Value = "XXX"
.Range("G2").Value = "PRICE"
.Range("H2").Value = "XXX"
.Range("I2").Value = "XXX"
End With
Next ws
Sheets.Select
Range("A1:I2").Select
With Selection
.Font.Size = 14
.Font.Bold = True
.Font.Color = vbWhite
.Interior.Color = vbBlue
End With
Range("A1").Select
Sheets("Tyres").Select
Workbooks(PriceFile.xls).Activate
m = 3
t = 3
For i = 1 To Workbooks(PriceFile.xls).Sheets.Count
For l = 1 To Cells(Rows.Count, "I").End(xlUp).Row
If Cells(i, 9).Value = "True" Then
Rows(i).Copy
Workbooks(ImportFile.xls).Activate
Worksheets("Mechanical").Select
Cells(m, 1).Select
ActiveSheet.Paste
m = m + 1
End If
If Cells(i, 9).Value = "False" Then
Rows(i).Copy
Workbooks(ImportFile.xls).Activate
Worksheets("Tyres").Select
Cells(t, 1).Select
ActiveSheet.Paste
t = t + 1
End If
Next l
Next i
End Sub
