Re: Diagramm
03.06.2003 15:57:57
Dan
Hallo Erich,
mit diesem makro kann man mehrere Sheets gleichzeitig offnen und ein bestimmtes range in ein neues workbook kopieren. Der range habe ich auf verschiedene sechs Zellen aufgestellt, aber man kann den range andern (siehe im code). Mfg. Dan.Option Explicit
Option Base 1
Public Sub DatenKopieren()
Dim myFiles As Variant, myFile As Variant, rDaten As Range
Dim iRow As Integer, iCol As Integer, rCell As Range
Dim wrb As Workbook, wks As Worksheet, wZielDatei As Workbook
On Error GoTo hErr
Set wZielDatei = Application.Workbooks.Add
myFiles = Application.GetOpenFilename("MS Excel Files (*.xls),*.xls", , "Dateien Offnen", , True)
iRow = 0
iCol = 0
If IsArray(myFiles) Then
For Each myFile In myFiles
Set wrb = Application.Workbooks.Open(myFile)
For Each wks In wrb.Worksheets
'den kopierten Range kann man hier andern
Set rDaten = Application.Union(wks.Range("A1:C1"), wks.Range("A3:C3"))
iRow = iRow + 1
iCol = 1
With wZielDatei.ActiveSheet
For Each rCell In rDaten.Cells
.Cells(iRow, iCol).Value = CStr(rCell.Value)
iCol = iCol + 1
Next rCell
.Cells(iRow, iCol).Value = CStr(wrb.Name) & " | " & wks.Name
End With
Next wks
wrb.Close
Next myFile
End If
Exit Sub
hErr:
MsgBox "Runtime Fehler, desc. : " & Err.Description
End
End Sub