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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen