Importing from CSV over multiple sheets

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Hi,

I have a CSV file that has approximately than 520 fields (yes, I know, it's
terrible) that I need to import into Excel. I have found a macro that will
let me import up to 510 fields but it cuts off the last 10. That macro can
be found here: http://support.microsoft.com/default.aspx?scid=kb;en-us;272729

I have only very limited VB skills and I was wondering if one of you kind
people could have a look at the code and tell me where I can change it to let
it import over 3 worksheets instead of 2?

Thanks very much in advance.
Cheers,
Verity
 
The code below does two things.

The first part generates a comma separated textfile with 50 rows and 600
columns
The second procedure reads the file and places the data in sheet1 to sheet3
The workbook has 4 sheets called "main", "sheet1", "sheet2", "sheet3"
each sheet will be populated with 255 columns, so as is, you could change
the builder to 765 (255x3) , add more sheets if you want more columns

the code reads a line in from the csv, drops it into column A of sheet
'main' then copies blocks off 255 rows to to each sheet in turn.

I think the code is relatively simple to follow.
when you copy the code to a standard module, run the procedure called
'RunTest' ..this will build the demo file & then populatet he workbook. Clear
the workbook. You can run the procedure called 'runMain' which allows you to
navigate in explorer to your file...


Option Explicit
Const textFile As String = "c:\temp\textdemo.txt"
Sub RunTest()
BuildTestFile
FetchData textFile
End Sub
Sub runMain()
Dim fn As String
fn = Application.GetOpenFilename()
If fn <> "" Then
FetchData fn
End If
End Sub
Sub BuildTestFile()
' set 50 rows
Const length As Long = 50
Dim text As String
Dim col As Long
Dim rw As Long
Dim ff As Long
ff = FreeFile
Open textFile For Output As ff
For rw = 1 To length
text = ""
For col = 1 To 600
text = text & "," & rw & "_" & col
Next
text = Mid(text, 2)
Print #ff, text
Next
Close
End Sub

Sub FetchData(sFilename As String)

Dim text As String
Dim col As Long
Dim rw As Long
Dim ff As Long
Dim data As Variant
Dim sheetnumber As Long
Dim depth As Long
ff = FreeFile
Open sFilename For Input As ff

Do Until EOF(ff)
Line Input #ff, text
rw = rw + 1
data = Split(text, ",")
depth = UBound(data, 1)
Range("A:A").Clear
Worksheets("main").Range("A1").Resize(depth) =
WorksheetFunction.Transpose(data)
For sheetnumber = 1 To Int(depth / 255) + 1
Worksheets("sheet" & sheetnumber).Range("A1").Offset(0, rw -
1).Resize(255).Value = _
Range("A1").Offset(255 * (sheetnumber - 1)).Resize(255).Value
Next

Loop
Close
End Sub
 
Hi Patrick,

Thanks for your help. I ran the code and the initial RunTest procedure
worked well and filled the rows and columns with the test data. I cleared
the worksheet as instructed and ran the RunMain procedure. The procedure
placed what should be the column names in the first column on each worksheet
and threw this error:

Runtime error "-2147417848 (80010108)':
Method 'Transpose' of object 'Worksheet Function' Failed.

This is where the code is stopped:
Worksheets("main").Range("A1").Resize(depth) =
WorksheetFunction.Transpose(data)

Any clues?

Thanks in advance for your help.
Verity

Any clues as to what this could mean? I'm going to
 
Verity said:
Hi,

I have a CSV file that has approximately than 520 fields (yes, I know, it's
terrible) that I need to import into Excel. I have found a macro that will
let me import up to 510 fields but it cuts off the last 10. That macro can
be found here: http://support.microsoft.com/default.aspx?scid=kb;en-us;272729
Click to expand...

Hi
I think the sample code above won't work correctly if a CSV file have data in it
something like "123","abc,def". I've tried to modify the code to work in such
case,
but I'm not sure if this macro would work or not in your case. Just for sample.

Sub LargeDatabaseImport3()
Dim rec() As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Long, maxcol As Long, maxrow As Long
Dim Comma As Integer
Dim WorkResult As String, tmp As String
Dim char As String
Dim i As Long, j As Long, k As Long, l As Long, wklen As Long
Dim instate As Boolean
Dim ws As Worksheet

On Error GoTo ErrorCheck
maxcol = Cells.Columns.Count
maxrow = Cells.Rows.Count
'Ask for the name of the file.
FileName = Application.GetOpenFilename(FileFilter:="Text file
(*.prn;*.txt;*.csv),*.prn;*.txt;*.csv")
'Check for no entry.
If FileName = "False" Then
Exit Sub
End If
'Turn off ScreenUpdating and Events so that users can't see what is
'happening and can't affect the code while it is running.
Application.ScreenUpdating = False
Application.EnableEvents = False
'Get next available file handle number.
FileNum = FreeFile()
'Open text file for input.
Open FileName For Input As #FileNum
'Turn ScreenUpdating off.
Application.ScreenUpdating = False
'Set the counter to 1.
Counter = 1
'Place the data in the first row of the column.
Range("A1").Activate
'Loop until the end of file is reached.
Do While Seek(FileNum) <= LOF(FileNum)
'Show row number being imported on status bar.
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName
'Store one line of text from file to variable.
Line Input #FileNum, WorkResult
'split the entire string and into temporary array rec().
k = 0
i = 1
j = 1
Comma = 0
tmp = ""
instate = False
wklen = Len(WorkResult)
Do While (i <= wklen)
char = Mid(WorkResult, i, 1)
If char = "," And Not instate Then
Comma = Comma + 1
tmp = tmp & char
char = Mid(WorkResult, i + 1, 1)
If char = "=" Then
tmp = tmp & "'" & char
i = i + 2
Else
i = i + 1
End If
ElseIf char = """" And instate Then
j = 1
tmp = tmp & char
char = Mid(WorkResult, i + j, 1)
If char = """" Then
Do While (char = """")
tmp = tmp & char
j = j + 1
char = Mid(WorkResult, i + j, 1)
Loop
If (j Mod 2) <> 0 Then
instate = True
Else
instate = False
End If
i = i + j
Else
instate = False
i = i + j
End If
ElseIf char = """" And Not instate Then
instate = True
tmp = tmp & char
i = i + 1
Else
tmp = tmp & char
i = i + 1
End If

If Comma = maxcol Then
ReDim Preserve rec(k)
rec(k) = Left(tmp, Len(tmp) - 1)
k = k + 1
WorkResult = Mid(WorkResult, Len(tmp) + 1)
wklen = Len(WorkResult)
i = 1
tmp = ""
instate = False
Comma = 0
End If
Loop

ReDim Preserve rec(k)
rec(k) = tmp

i = 1
l = 0
Do While (l <= UBound(rec))
On Error Resume Next
Set ws = Nothing
Set ws = Worksheets(i)
If ws Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add(after:=ActiveSheet)
End If
On Error GoTo ErrorCheck
ws.Select
Cells(Counter, 1) = rec(l)
If rec(l) <> "" Then
Application.DisplayAlerts = False
Cells(Counter, 1).TextToColumns Destination:=Cells(Counter, 1),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False
'FieldInfo _
:=Array(Array(1, 1), Array(4, 1))
End If
l = l + 1
i = i + 1
Loop
Counter = Counter + 1
If Counter > maxrow Then
MsgBox "data have over max rows"
Exit Sub
End If
ReDim rec(0)
Loop
'Close the open text file.
Close
'Reset the application to its normal operating environment.
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ErrorCheck:
'Reset the application to its normal operating environment.
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "An error occured in the code."
End Sub

keizi
 
Oh wow, that worked absolutely perfectly! Thanks so much for your help! I am
forever in your debt :-)

Cheers,
Verity
 
Back
Top