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

"joel" schrieb im Newsbeitrag
...
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







"Volker Hormuth" wrote:

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