Importing numerous files

[smurray444]

Dear all,

I have some VBA code which reads in a long text file into Excel 2007, and when it reaches the bottom of the worksheet creates a new one and carries on importing until reaching the end of the file.

However, it only reads in a single file at a time. I was wondering if it would be possible to automate the reading in of all of my 29 files in one go (where the code increments the file name by one each time from 1961 up to 1990): the file name format is out_lpj_year1961.txt, out_lpj_year1962.txt, out_lpj_1963.txt up to out_lpj_1990.txt.

Each text file is composed of 3 columns; for the first file to be imported (out_lpj_year1961.txt) I need all 3 columns going into Excel. Yet for the rest, I need only the third column being inserted in next to the existing column (i.e. the row count shouldn't increase, only the number of columns). The total column count should equal 31 (29 files of which the 3rd column from each one is imported, plus the extra two from the 1st file).

The code as it stands is:

Attribute VB_Name = "Module1"
'"Text Files (*.txt),*.txt
Option Explicit
Sub LargeFileImport()
Const MaxRows As Long = 1048576
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
Dim num() As Single
Dim v As Variant, i As Long, j As Long
Dim s As String, sChr As String
Dim rw As Long
'Ask User for File's Name
FileName = Application.GetOpenFilename( _
FileFilter:="Text Files (*.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
'Create A New WorkBook With One Worksheet In It
Workbooks.Add template:=xlWorksheet
'Set The Counter to 1
Counter = 1
'Loop Until the End Of File Is Reached
s = ""
rw = 1
Do While Seek(FileNum) <= LOF(FileNum)
'Display Importing Row Number On Status Bar
' Application.StatusBar =
Debug.Print "Importing Row " & _
Counter & " of text file " & FileName
'Store One Line Of Text From File To Variable
ResultStr = Input(1000, #FileNum)
'Store Variable Data Into Active Cell
For i = 1 To Len(ResultStr)
sChr = Mid(ResultStr, i, 1)
If Asc(sChr) = 10 Then
If Len(Trim(s)) > 0 Then
v = Split(Application.Trim(s), " ")
ReDim num(LBound(v) To UBound(v))
For j = LBound(v) To UBound(v)
num(j) = CSng(v(j))
Next
Cells(rw, 1).Resize(1, _
UBound(v) - LBound(v) + 1) = num
rw = rw + 1
s = ""
Erase v
If rw > MaxRows Then
ActiveWorkbook.Sheets.Add
rw = 1
End If
End If
Else
s = s & sChr
End If
Next
'Increment the Counter By 1
Counter = Counter + 1
' If Counter > 1E+307 Then
' Exit Do
' End If
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
If Len(Trim(s)) > 0 Then
v = Split(Application.Trim(s), " ")
ReDim num(LBound(v) To UBound(v))
For j = LBound(v) To UBound(v)
num(j) = CSng(v(j))
Next
Cells(rw, 1).Resize(1, _
UBound(v) - LBound(v) + 1) = num
rw = rw + 1
s = ""
Erase v
If rw > 1048576 Then
ActiveWorkbook.Sheets.Add
rw = 1
End If
End If
'Remove Message From Status Bar
Application.StatusBar = False
End Sub

Just to add that I didn't write this code myself! I'm useless at VBA; this was taken from the MS website and adapted slightly by someone who knows far more about VBA than me!

If you would be able to make the amendments I've suggested, then I'd be very grateful. Also if you need any further clarification then please do not hesitate to ask me.

Many thanks for your help and time,

Steve

 

[hsk]

try this .... the following macro will open the text files in given path one by one, import the data, delimit on Spaces, delete 1st 2 columns

Sub Macro6()
    Range("A1").Select
    d = 1
    For fnum = 1961 To 1990
    fname = "TEXT;C:\....ur path ....\out_lpj_year" & fnum & ".txt"
    With ActiveSheet.QueryTables.Add(Connection:=fname, Destination:=Cells(1, d))
        .Name = "test" & i
        .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 = True
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(2, 2, 2)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    If d = 1 Then
       d = d + 3
    Else
       Cells(1, d).EntireColumn.Delete shift:=xlToLeft
       Cells(1, d).EntireColumn.Delete shift:=xlToLeft
       d = d + 1
    End If
    Next
End Sub

 

[smurray444]

Hi again - thanks for your reply.

However, when I run it (with the correct file path), I get runtime error 1004 - application defined or object defined error. Does anyone have any idea what this might mean and how it could be corrected?

Also, the original code that I listed enables the data that won't fit onto one sheet to over-run onto a second sheet - does this latest code also do this? If not, how would the two codes be patched together to achieve this?

Many thanks for your help
smurray444

 

[smurray444]

Does anyone have any suggestions for this?

Thanks

 

[hsk]

added the logic to insert new sheet if one sheet is over-run ....
@ the error .... on what line u r getting that error, it will be good if u can put ur code on the forum .....

Sub Macro6() 
    Range("A1").Select 
    d = 1 
    For fnum = 1961 To 1990 
    fname = "TEXT;C:\....ur path ....\out_lpj_year" & fnum & ".txt" 
    With ActiveSheet.QueryTables.Add(Connection:=fname, Destination:=Cells(1, d)) 
        .Name = "test" & i 
        .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 = True 
        .TextFileTabDelimiter = False 
        .TextFileSemicolonDelimiter = False 
        .TextFileCommaDelimiter = False 
        .TextFileSpaceDelimiter = True 
        .TextFileColumnDataTypes = Array(2, 2, 2) 
        .TextFileTrailingMinusNumbers = True 
        .Refresh BackgroundQuery:=False 
    End With 
    If d = 1 Then 
       d = d + 3 
    Else 
       Cells(1, d).EntireColumn.Delete shift:=xlToLeft 
       Cells(1, d).EntireColumn.Delete shift:=xlToLeft 
       d = d + 1 
    End If 
    If d > 250 Then
        sheets.Add
    End If
    Next 
End Sub