Joel - Importing multiple text files to 1 spreadsheet, now importing from excel files

V

Volker Hormuth

Hi All,

I found the following example of the processing of text files in the
newsgroup (thread 29.09.2008). The program flow is wished as well as by me.
Nevertheless, the reading should occur from Excel-sheets.
I have already tried to find from examples of Ron de Bruin and the code of
Joel a solution. But I have not managed this.
Only the import of the source sheets in the sheet "Input" would have to be
customised.

From all files of a folder will be imported in each case from a certain
sheet two Columns. The sheet names are Jahr2008, Jahr2007, Jahr2006.......
The first part of the sheet name is always "Jahr", followed by the annual
number. The sheet construction is in each case in column A (ID), in column
D (Betrag). These both columns should be imported in a sheet called "Input",
there in the columns A (ID) and column B (Betrag).

From there the data will be transmitted into a sheet called "Summary". This
occurs sheet-wise, i.e. reading of the first sheet in "Input", then carry to
"Summary", afterwards reading of the second sheet in "Input", then carry to
"Summary" etc. If the ID exists, the corresponding value is entered on the
annual column. A not yet available ID is complemented below in column A. The
sheet construction is displayed in the following. Column A shows ID, in the
following columns B, C... the accompanying amounts are entered. A new column
is put on for every year.
The headers are marked as follows: A1 ID, B1 Jahr2008, C1 Jahr2007, D1
Jahr2006 etc... Jahr2008, 2007 are the sheet names from the original source
files.

Input-Sheet year 1
A B
ID Jahr2008
key01 10
key04 20
key07 30

Input-Sheet year 2
A B
ID Jahr2007
key01 15
key02 25
key04 50
key08 22

Summary-Sheet
A B C
ID Jahr2008 Jahr2007
key01 10 15
key04 20 50
key07 30
key02 25
key08 22

Sub DatenEinlesen()
Folder = "C:\temp\test2\"
With ThisWorkbook
Set InputSht = Worksheets.Add( _
after:=.Sheets(.Sheets.Count))
InputSht.Name = "Input"
Set SummarySht = Worksheets.Add( _
after:=.Sheets(.Sheets.Count))
SummarySht.Name = "Summary"
SummarySht.Range("A1") = "ID"
End With

ColCount = 2
NewRow = 2
FName = Dir(Folder & "*.xls")
Do While FName <> ""

----------------------------------------------------
----- This code part is to be replaced ----

'Input data file
With InputSht
.Cells.ClearContents
With .QueryTables.Add( _
Connection:="TEXT;" & Folder & FName, _
Destination:=.Range("A1"))

.Name = FName
.SaveData = True
.AdjustColumnWidth = True
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileFixedColumnWidths = Array(16, 10)
.Refresh BackgroundQuery:=False
End With
-------------------------------------------------------------

'Move Data to Summary sheet
SummarySht.Cells(1, ColCount) = FName
RowCount = 2
Do While .Range("A" & RowCount) <> ""
ID = .Range("A" & RowCount)
Betrag = .Range("B" & RowCount)
With SummarySht
Set c = .Columns("A").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & NewRow) = ID
.Cells(NewRow, ColCount) = Betrag
NewRow = NewRow + 1
Else
.Cells(c.Row, ColCount) = Betrag
End If
End With
RowCount = RowCount + 1
Loop
End With
ColCount = ColCount + 1
FName = Dir()
Loop
End Sub

I would be very grateful for every help.
Volker
 
J

joel

I didn't test the code. You will need to change FOLDER as required. I
eliminated the Input Sheet and move the data directly from each of the
workbooks to the summary sheet. I assume each workbook had multiple
worksheet with differnt the code will work even with one worksheet in each
workbook. The code is using the TAB name of the sheets to determine the
column names in the summary sheet.

Sub DatenEinlesen()
Folder = "C:\temp\test2\"
With ThisWorkbook
Set SummarySht = .Worksheets.Add( _
after:=.Sheets(.Sheets.Count))
SummarySht.Name = "Summary"
SummarySht.Range("A1") = "ID"
End With

With SummarySht

NewRow = 2
NewCol = 2
FName = Dir(Folder & "*.xls")
Do While FName <> ""
Set OldBk = Workbooks.Open(Filename:=Folder & FName)
For Each Sht In OldBk.Sheets
If UCase(Left(Sht.Name, 4)) = "JAHR" Then

'Test if columnn already exists
Set c = .Rows(1).Find(what:=Sht.Name, _
LookIn:=xlValues, lookat:=xlwhat)
If c Is Nothing Then
.Cells(1, NewCol) = Sht.Name
ColCount = NewCol
NewCol = NewCol + 1
Else
ColCount = c.Column
End If

RowCount = 2

'Move Data to Summary sheet
Do While Sht.Range("A" & RowCount) <> ""
ID = Sht.Range("A" & RowCount)
Betrag = Sht.Range("B" & RowCount)

Set c = .Columns("A").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & NewRow) = ID
.Cells(NewRow, ColCount) = Betrag
NewRow = NewRow + 1
Else
.Cells(c.Row, ColCount) = Betrag
End If
RowCount = RowCount + 1
Loop
End If
Next Sht
OldBk.Close savechanges:=False
FName = Dir()
Loop
End With
End Sub
 
V

Volker Hormuth

Hallo Joel,
many thanks for the quick response.
At this point I receive an error message ( Nr 9 Laufzeitfehler - Index
ausserhalb des Bereichs)

'Test if columnn already exists
Set c = .Rows(1).Find(what:=Sht.Name, _
LookIn:=xlValues, lookat:=xlwhat)

How must I change the code?

Volker
 
J

joel

I misspelled the word xlWhole

'Test if columnn already exists
Set c = .Rows(1).Find(what:=sht.Name, _
LookIn:=xlValues, lookat:=xlWhole)
 
V

Volker Hormuth

Hi Joel,

the code runs as well as I have wished it. I will save with it in future a
lot of time.
Again many thanks for your help. I still wish you nice Sunday.

Volker
 
R

ryguy7272

This is how I import multiple text files into one Sheet:
Sub Import_Multiple_Text_Files()

Dim F As Variant
Dim x As Integer

Const MyPath = "c:\temp\"

first = True

RowCount = 1
Do
If first = True Then
Filename = Dir(MyPath & "*.txt")
first = False
Else
Filename = Dir()
End If

If Filename <> "" Then

Open (MyPath & Filename) For Input Access Read As #1
Do Until EOF(1)
Line Input #1, qdata
If qdata <> "" Then
Cells(RowCount, 1) = qdata
RowCount = RowCount + 1
End If
Loop
Close #1
End If
Loop While Filename <> ""
End Sub

Similar to above, but with a slight twist:
Sub Import_Multiple_Text_Files()
Dim FileS As FileSearch
Dim F As Variant
Dim x As Integer
'switch calculation off to speed up macro
Application.Calculation = xlManual
'Pick up file path information
qfolder = [B5]
Set FileS = Application.FileSearch
With FileS
.NewSearch
.Filename = "*"
.LookIn = qfolder
.SearchSubFolders = True
.Execute
End With
x = 1
Sheets("Data").Select
For Each F In Application.FileSearch.FoundFiles
Open F For Input Access Read As #1
Do Until EOF(1)
Line Input #1, qdata
If qdata <> "" Then
Cells(x, 1) = qdata
x = x + 1
End If
Loop
Close #1
Next F
End Sub

Cell B5 has this:
C:\Test


HTH,
Ryan---
 
R

Ron de Bruin

See also
http://www.rondebruin.nl/csv.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm




ryguy7272 said:
This is how I import multiple text files into one Sheet:
Sub Import_Multiple_Text_Files()

Dim F As Variant
Dim x As Integer

Const MyPath = "c:\temp\"

first = True

RowCount = 1
Do
If first = True Then
Filename = Dir(MyPath & "*.txt")
first = False
Else
Filename = Dir()
End If

If Filename <> "" Then

Open (MyPath & Filename) For Input Access Read As #1
Do Until EOF(1)
Line Input #1, qdata
If qdata <> "" Then
Cells(RowCount, 1) = qdata
RowCount = RowCount + 1
End If
Loop
Close #1
End If
Loop While Filename <> ""
End Sub

Similar to above, but with a slight twist:
Sub Import_Multiple_Text_Files()
Dim FileS As FileSearch
Dim F As Variant
Dim x As Integer
'switch calculation off to speed up macro
Application.Calculation = xlManual
'Pick up file path information
qfolder = [B5]
Set FileS = Application.FileSearch
With FileS
.NewSearch
.Filename = "*"
.LookIn = qfolder
.SearchSubFolders = True
.Execute
End With
x = 1
Sheets("Data").Select
For Each F In Application.FileSearch.FoundFiles
Open F For Input Access Read As #1
Do Until EOF(1)
Line Input #1, qdata
If qdata <> "" Then
Cells(x, 1) = qdata
x = x + 1
End If
Loop
Close #1
Next F
End Sub

Cell B5 has this:
C:\Test


HTH,
Ryan---

--
Ryan---
If this information was helpful, please indicate this by clicking ''Yes''.


Volker Hormuth said:
Hi Joel,

the code runs as well as I have wished it. I will save with it in future a
lot of time.
Again many thanks for your help. I still wish you nice Sunday.

Volker
Click to expand...
Click to expand...
 
V

Volker Hormuth

Hi Ron and Ryguy 7272,

many thanks for the complementary information.

Volker


Ron de Bruin said:
See also
http://www.rondebruin.nl/csv.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm




ryguy7272 said:
This is how I import multiple text files into one Sheet:
Sub Import_Multiple_Text_Files()

Dim F As Variant
Dim x As Integer

Const MyPath = "c:\temp\"

first = True

RowCount = 1
Do
If first = True Then
Filename = Dir(MyPath & "*.txt")
first = False
Else
Filename = Dir()
End If

If Filename <> "" Then

Open (MyPath & Filename) For Input Access Read As #1
Do Until EOF(1)
Line Input #1, qdata
If qdata <> "" Then
Cells(RowCount, 1) = qdata
RowCount = RowCount + 1
End If
Loop
Close #1
End If
Loop While Filename <> ""
End Sub Similar to above, but with a slight twist:
Sub Import_Multiple_Text_Files()
Dim FileS As FileSearch
Dim F As Variant
Dim x As Integer
'switch calculation off to speed up macro
Application.Calculation = xlManual
'Pick up file path information
qfolder = [B5]
Set FileS = Application.FileSearch
With FileS
.NewSearch
.Filename = "*"
.LookIn = qfolder
.SearchSubFolders = True
.Execute
End With
x = 1
Sheets("Data").Select
For Each F In Application.FileSearch.FoundFiles
Open F For Input Access Read As #1
Do Until EOF(1)
Line Input #1, qdata
If qdata <> "" Then
Cells(x, 1) = qdata
x = x + 1
End If
Loop
Close #1
Next F
End Sub

Cell B5 has this: C:\Test


HTH,
Ryan---

--
Ryan---
If this information was helpful, please indicate this by clicking
''Yes''.


Volker Hormuth said:
Hi Joel,

the code runs as well as I have wished it. I will save with it in future
a lot of time.
Again many thanks for your help. I still wish you nice Sunday.

Volker


I misspelled the word xlWhole

'Test if columnn already exists
Set c = .Rows(1).Find(what:=sht.Name, _
LookIn:=xlValues, lookat:=xlWhole)


:

Hallo Joel,
many thanks for the quick response.
At this point I receive an error message ( Nr 9 Laufzeitfehler -
Index
ausserhalb des Bereichs)

'Test if columnn already exists
Set c = .Rows(1).Find(what:=Sht.Name, _
LookIn:=xlValues, lookat:=xlwhat)

How must I change the code?

Volker

I didn't test the code. You will need to change FOLDER as required.
I
eliminated the Input Sheet and move the data directly from each of
the
workbooks to the summary sheet. I assume each workbook had
multiple
worksheet with differnt the code will work even with one
worksheet in
each
workbook. The code is using the TAB name of the sheets to determine
the
column names in the summary sheet.

Sub DatenEinlesen()
Folder = "C:\temp\test2\"
With ThisWorkbook
Set SummarySht = .Worksheets.Add( _
after:=.Sheets(.Sheets.Count))
SummarySht.Name = "Summary"
SummarySht.Range("A1") = "ID"
End With

With SummarySht

NewRow = 2
NewCol = 2
FName = Dir(Folder & "*.xls")
Do While FName <> ""
Set OldBk = Workbooks.Open(Filename:=Folder & FName)
For Each Sht In OldBk.Sheets
If UCase(Left(Sht.Name, 4)) = "JAHR" Then

'Test if columnn already exists
Set c = .Rows(1).Find(what:=Sht.Name, _
LookIn:=xlValues, lookat:=xlwhat)
If c Is Nothing Then
.Cells(1, NewCol) = Sht.Name
ColCount = NewCol
NewCol = NewCol + 1
Else
ColCount = c.Column
End If

RowCount = 2

'Move Data to Summary sheet
Do While Sht.Range("A" & RowCount) <> ""
ID = Sht.Range("A" & RowCount)
Betrag = Sht.Range("B" & RowCount)

Set c = .Columns("A").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & NewRow) = ID
.Cells(NewRow, ColCount) = Betrag
NewRow = NewRow + 1
Else
.Cells(c.Row, ColCount) = Betrag
End If
RowCount = RowCount + 1
Loop
End If
Next Sht
OldBk.Close savechanges:=False
FName = Dir()
Loop
End With
End Sub







:

Hi All,

I found the following example of the processing of text files in
the
newsgroup (thread 29.09.2008). The program flow is wished as well
as by
me.
Nevertheless, the reading should occur from Excel-sheets.
I have already tried to find from examples of Ron de Bruin and the
code
of
Joel a solution. But I have not managed this.
Only the import of the source sheets in the sheet "Input" would
have to
be
customised.

From all files of a folder will be imported in each case from a
certain
sheet two Columns. The sheet names are Jahr2008, Jahr2007,
Jahr2006.......
The first part of the sheet name is always "Jahr", followed by the
annual
number. The sheet construction is in each case in column A (ID),
in
column
D (Betrag). These both columns should be imported in a sheet
called
"Input",
there in the columns A (ID) and column B (Betrag).

From there the data will be transmitted into a sheet called
"Summary".
This
occurs sheet-wise, i.e. reading of the first sheet in "Input",
then carry
to
"Summary", afterwards reading of the second sheet in "Input", then
carry
to
"Summary" etc. If the ID exists, the corresponding value is
entered on
the
annual column. A not yet available ID is complemented below in
column A.
The
sheet construction is displayed in the following. Column A shows
ID, in
the
following columns B, C... the accompanying amounts are entered. A
new
column
is put on for every year.
The headers are marked as follows: A1 ID, B1 Jahr2008, C1
Jahr2007, D1
Jahr2006 etc... Jahr2008, 2007 are the sheet names from the
original
source
files.

Input-Sheet year 1
A B
ID Jahr2008
key01 10
key04 20
key07 30

Input-Sheet year 2
A B
ID Jahr2007
key01 15
key02 25
key04 50
key08 22

Summary-Sheet
A B C
ID Jahr2008 Jahr2007
key01 10 15
key04 20 50
key07 30
key02 25
key08 22

Sub DatenEinlesen()
Folder = "C:\temp\test2\"
With ThisWorkbook
Set InputSht = Worksheets.Add( _
after:=.Sheets(.Sheets.Count))
InputSht.Name = "Input"
Set SummarySht = Worksheets.Add( _
after:=.Sheets(.Sheets.Count))
SummarySht.Name = "Summary"
SummarySht.Range("A1") = "ID"
End With

ColCount = 2
NewRow = 2
FName = Dir(Folder & "*.xls")
Do While FName <> ""

----------------------------------------------------
----- This code part is to be replaced ----

'Input data file
With InputSht
.Cells.ClearContents
With .QueryTables.Add( _
Connection:="TEXT;" & Folder & FName, _
Destination:=.Range("A1"))

.Name = FName
.SaveData = True
.AdjustColumnWidth = True
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileFixedColumnWidths = Array(16, 10)
.Refresh BackgroundQuery:=False
End With
-------------------------------------------------------------

'Move Data to Summary sheet
SummarySht.Cells(1, ColCount) = FName
RowCount = 2
Do While .Range("A" & RowCount) <> ""
ID = .Range("A" & RowCount)
Betrag = .Range("B" & RowCount)
With SummarySht
Set c = .Columns("A").Find(what:=ID, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & NewRow) = ID
.Cells(NewRow, ColCount) = Betrag
NewRow = NewRow + 1
Else
.Cells(c.Row, ColCount) = Betrag
End If
End With
RowCount = RowCount + 1
Loop
End With
ColCount = ColCount + 1
FName = Dir()
Loop
End Sub

I would be very grateful for every help.
Volker
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Joel - Data Consolidate Limitation 0
Add the word "and" in my code 12
create new worksheet"ERROR" 0
Importing multiple files 1
Matching Rows 2nd try 2
ERROR 424" OBJECT REQUIRED 1
Run-Time Error "9". Subscript out of range 3
Why ? What is error 424 ? 2

Top