Macro knippen uit een ander excel bestand en plakken onder de laatste actieve cel

[Tweety1]

Hi,

Wat ik graag zou willen is dat ik van meerdere excel bestanden met de zelfde opmaak (filenaam veranderd) vanaf A11 kan kopiëren in een nieuw bestand.

De volgende macro heb ik gevonden waarmee je bestanden kan openen alleen lukt het me niet om geknipte cellen on de laatste actieve cel (A1) te plaatsen/aanvullen.


Sub InhoudKopieren()

Dim sh1b As Object
Dim sh1a As Object
Dim oBoek1 As Object
Dim objBs As Variant
Dim fDialoog As FileDialog
Dim sBestandsnaam As String
Dim sNaam As String
Dim sPad As String

'Stel het werkboek en het pad in.
Set oBoek1 = ThisWorkbook
sPad = oBoek1.Path
'Pas het fiiledialoog aan en open het
Set fDialoog = Application.FileDialog(msoFileDialogOpen)
With fDialoog
.Title = "Selecteer het te kopiëren Werboek"
.ButtonName = "Kopieer bord"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "1. Excel 2007", "*.xlsx"
.InitialView = msoFileDialogViewDetails
.InitialFileName = sPad
.Show
'Haal bestandsnaam op.
For Each objBs In .SelectedItems
sBestandsnaam = objBs
Next objBs
End With
'Juist bestand geslecteerd?
If sBestandsnaam = "" Then
MsgBox "Er is geen bestand geselecteerd"
GoTo ResetAlles
End If
sNaam = Strings.Mid(sBestandsnaam, InStrRev(sBestandsnaam, "\") + 1)
If sBestandsnaam = oBoek1.Name Then
MsgBox "Wijzig eerst de naam van het bestand" & vbLf & _
"Start dan de kopieer routine opnieuw."
GoTo ResetAlles
End If
If Strings.InStr(1, Strings.UCase(sBestandsnaam), "xlsx", 1) = 0 Then
MsgBox "Onbekend bestand: " & sNaam & vbLf & vbLf _
& "Het geselecteerde bestand wordt niet herkend als Excel Werkboek" & vbLf _
& "Start de kopieer routine opnieuw en selecteer het juiste bestand." & vbLf _

GoTo ResetAlles
End If
On Error GoTo Fout
'klaarmaken voor kopiëeren
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'open het werkboek
Workbooks.Open sBestandsnaam
'kopieer
Set oBoek2 = ActiveWorkbook
Set sh1a = oBoek1.Worksheets(1)
Set sh1b = oBoek2.Worksheets(1)
sh1b.Range("A11", "AZ50").Copy
sh1a.Range("a5").PasteSpecial Paste:=xlPasteValues
'Sluit het bronbestand en ga naar het eerste blad
oBoek2.Close
sh1a.Activate
sh1a.Cells(1, 1).Select
'Zet alles weer op 0
ResetAlles:
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
Set sh1a = Nothing
Set sh1b = Nothing
Set oBoek1 = Nothing
Set fDialoog = Nothing
On Error GoTo 0
Exit Sub
' foutafhandeling ------------------------------------
Fout:
MsgBox "Kopieerfout:" & vbLf _
& "Het geselcteerde bestand wordt" & vbLf _
& "niet herkend als factbord." & vbLf _
& "Start de kopieer routine opnieuw" & vbLf _
& "en selecteer het juiste bestand."
Unload UfWacht
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

mvg

Kasper

 

[edmoor]

Dit is niet te volgen zo.
Zet eerst je code in een codetag.

 

[Warme bakkertje]

sh1a.Range("A" & rows.count).end(xlup).offset(1).PasteSpecial Paste:=xlPasteValues

 

[Tweety1]

Bedankt voor de hulp