AW: Gleiche Zellen kopieren
23.03.2009 19:37:37
fcs
Hallo Andreas,
Hier mal ein Beispiel-Code. Erarbeitet ausgehend vom aktiven Blatt.
Die Konstanten und den Schleifenzähler muss du ggf. noch anpassen.
Gruß
Franz
Sub ZeilenKopieren()
Dim wksQ As Worksheet, wksZ As Worksheet
Dim ZeileQ As Long, bolCopy As Boolean
Dim ZeileZ As Long, SPalteZ As Long, ZelleZ As Long, varName As Variant
Const SpalteA = 1 '1. zu kopierende Spalte
Const spalteE = 10 'letzte. zu kopierende Spalte ggf. Anpassen!!!
Set wksQ = ActiveSheet
ActiveWorkbook.Worksheets.Add
Set wksZ = ActiveSheet
With wksQ
ZeileZ = 0
For ZeileQ = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row
If ZeileZ = 0 Then '1. Eintrag
ZeileZ = ZeileZ + 1
SPalteZ = 1
bolCopy = True
varName = .Cells(ZeileQ, 4).Text
Else
'Prüfen ob Name geändert zu vorheriger Zeile
If .Cells(ZeileQ, 4) = varName Then
SPalteZ = SPalteZ + spalteE
bolCopy = True
Else
varName = .Cells(ZeileQ, 4).Text 'neuer Name
SPalteZ = 1
'Prüfen, ob Name schon vorhanden
If wksZ.Columns(4).Find(what:=varName, LookIn:=xlValues, lookat:=xlWhole) _
Is Nothing Then
ZeileZ = ZeileZ + 1
bolCopy = True
Else
If MsgBox("Der Name """ & varName & """ wurde bereits übertragen! " _
& vbLf & vbLf _
& "Trotzdem kopieren?", vbQuestion + vbYesNo) = vbYes Then
ZeileZ = ZeileZ + 1
bolCopy = True
'Zeile Markieren
wksZ.Cells(ZeileZ, 1 + 4 * spalteE) = "mehrfach"
End If
End If
End If
End If
If bolCopy = True Then
.Range(.Cells(ZeileQ, SpalteA), .Cells(ZeileQ, spalteE)).Copy
wksZ.Cells(ZeileZ, SPalteZ).PasteSpecial Paste:=xlPasteFormats
wksZ.Cells(ZeileZ, SPalteZ).PasteSpecial Paste:=xlPasteValues
End If
Next
Application.CutCopyMode = False
wksZ.Columns.AutoFit
End With
End Sub