Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1060to1064
1060to1064
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Gleiche Zellen kopieren

Forumthread: Gleiche Zellen kopieren

Gleiche Zellen kopieren
23.03.2009 14:51:11
Andreas

Hallo Leute !
Ich brauche mal wieder eure Hilfe. Ich habe eine Tabelle ( Ergebnisse1.1) die wird aus einer Userform erstellt. Jetzt möchte ich das alle Zeilen die den gleichen Namen haben ( Spalte D), werden max. 4 gleiche sein, in eine neue Tabelle kopiert werden und zwar hintereinander und nicht untereinander. Das ist wichtig damit ich die später sortieren kann.( Zwischen2). Mit suchen und kopieren habe ich schon probiert, allerdings funktionierte das nur untereinander. Und wenn der Name schon in der neuen Tabelle vorhanden ist, soll eine Meldung erfolgen. Am liebsten wäre es mir in vba.
Hoffe Problem ist klar.
Gruß Andreas
https://www.herber.de/bbs/user/60584.xls
Anzeige

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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


Anzeige
AW: Gleiche Zellen kopieren
23.03.2009 21:11:09
Andreas
Hallo Franz !
Habe deinen Code getestet und ein wenig geändert. Funktioniert so weit, nur schreibt er das erste in eine Zeile und die anderen 3 in eine Zeile. Aber es sollen alle 4 in einer Zeile stehen. Und funktioniert es in dem Beispiel nur bei den 2 vorhanden vereinen. Die Liste wird aber länger. Habe zwar schon viel gemacht mit vba, aber soweit reichen meine Kentnisse nicht. Mit der Meldung soll verhindert werden, das die komplette Zeile doppelt vorhanden ist.
Vielen Dank für deine Mühen.
Gruß Andreas
Anzeige
AW: Gleiche Zellen kopieren
23.03.2009 23:12:08
Andreas
Hallo zusammen,
Thema hat sich erledigt. Habe selbst eine Lösung gefunden. Ist zwar etwas komplizierter und auch zu aufwendig um hier darzustellen. Trotzdem Danke an alle.
Gruß Andreas
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige