Sub myCopy()
Dim wks As Worksheet
Dim lZ As Long
For Each wks In Worksheets
If Not ActiveSheet.Name = wks.Name Then
lZ = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wks.Range("A1:D4").Copy ActiveSheet.Range("A" & lZ + 1)
End If
Next
End Sub
Viele Grüße
Herby
Sub DatenRein()
Dim strDatei As String, lngRow As Long
Dim wksZiel As Worksheet, wkbQuelle As Workbook
Const iImport As Integer = 4
Const strPfad As String = "c:\Test\" 'Quellordner
Const iBeginn As Integer = 1 '1.Zeile
Const iEnde As Integer = 4 'letzte Zeile
Application.ScreenUpdating = False
Set wksZiel = ThisWorkbook.Sheets(1)
strDatei = Dir(strPfad & "*.xls", vbNormal)
If Len(strDatei) > 0 Then
Do
If Not strDatei = ThisWorkbook.Name Then
Set wkbQuelle = Workbooks.Open(strPfad & strDatei)
lngRow = wksZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wkbQuelle.Sheets(1).Range(Rows(iBeginn), Rows(iEnde)).Copy _
wksZiel.Cells(lngRow, 1)
wkbQuelle.Close False
End If
strDatei = Dir
Loop Until strDatei = ""
End If
Application.ScreenUpdating = True
End Sub
Gruß
Rudi
Sub DatenRein()
Dim strDatei As String, lngRow As Long
Dim wksZiel As Worksheet, wkbQuelle As Workbook
Const iImport As Integer = 4
Const strPfad As String = "c:\Test\" 'Quellordner
Const iBeginn As Integer = 1 '1.Zeile
Const iEnde As Integer = 4 'letzte Zeile
Application.ScreenUpdating = False
Set wksZiel = ThisWorkbook.Sheets(1)
strDatei = Dir(strPfad & "*.xls", vbNormal)
If Len(strDatei) > 0 Then
Do
If Not strDatei = ThisWorkbook.Name Then
Set wkbQuelle = Workbooks.Open(strPfad & strDatei)
lngRow = wksZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With wkbQuelle.Sheets(1)
.Range(.Rows(iBeginn), .Rows(iEnde)).Copy wksZiel.Cells(lngRow, 1)
End With
wkbQuelle.Close False
End If
strDatei = Dir
Loop Until strDatei = ""
End If
Application.ScreenUpdating = True
End Sub
Gruß
Rudi