Kopieren und Einfügen
22.10.2013 13:26:21
Petra
ich habe mal wieder ein Problem und wahrscheinlich ist mein Code erschreckend. Tut mir jetzt schon mal leid! Ich habe meine Kenntnisse nur durch Macrorecorder, es sei mir verziehen. Ich habe ein Copy und Paste Problem, was manchmal geht manchmal nicht. Es gibt ein Übersichtsblatt, auf dem alles was in den anderen Blättern steht kopiert werden soll. Orientieren soll es sich nach der Spalte Title (die nicht immer genau Title heißt), deshalb *Title*. Ab dieser Spalte sollen insgesamt 5Spalten (mit Title) nach rechts kopiert werden und auf Übersichtsblatt eingefügt werden. Daraufhin soll links vom Title alles was befüllt ist kopiert werden und auf dem Übersichtsblatt eingefügt werden. Es gibt manchmal unter Zeile Title eine Leerzeile, deshalb die If-Verzweigung:
Sub kopieren_einfügen()
Dim i As Integer
Dim a As Integer
Dim b As Integer
Dim Tabblätter As Integer
b = ActiveWorkbook.Worksheets.Count
Application.ScreenUpdating = False
For Tabblätter = 2 To b
On Error Resume Next
Sheets(Tabblätter).Activate
a = 1
i = 1
For i = 1 To 10
For a = 1 To 10
If Cells(i, a) Like "*Title*" Then
If IsEmpty(Cells(i, a).Offset(1, 0)) Then
Cells(i, a).Offset(2, 0).Activate
Else
Cells(i, a).Offset(1, 0).Activate
End If
ActiveCell.Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Tabelle1.Select
Range("H5").Select
If ActiveCell "" Then
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Activate
End If
ActiveSheet.Paste
Sheets(Tabblätter).Activate
If IsEmpty(Cells(i, a).Offset(1, 0)) Then
Cells(i, a).Offset(2, -1).Activate
Else
Cells(i, a).Offset(1, -1).Activate
End If
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Tabelle1.Select
Range("A5").Select
If ActiveCell "" Then
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Activate
End If
ActiveSheet.Paste
GoTo exitloop
End If
Next
Next
exitloop:
Next
Application.ScreenUpdating = True
End Sub
Vielen Dank für eure Hilfe schon vorab:-)
Viele Liebe Grüße
Petra