Ganze Zelle kopieren wenn Text in Zeile

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Abteilunen_kopieren() Dim TabTxt As String, i As Integer Dim AC As Range, lzx, lz1 As Long Application.ScreenUpdating = False 'vorhandene Tabellen ermitteln For i = 1 To Worksheets.Count TabTxt = TabTxt & ", " & Worksheets(i).Name Next i '** vorhandene Tabellen zuerst löschen!! For i = 1 To Worksheets.Count If Left(Worksheets(i).Name, 3) = "Abt" Then _ Worksheets(i).Cells.Clear Next i With Worksheets("Tabelle1") 'Name deiner Liste!! 'LastCell in Tabelle mit Abteilungen lz1 = .Cells(Rows.Count, 3).End(xlUp).Row 'Alle Daten in einzelne Tabellen kopieren For Each AC In .Range("C2:C" & lz1) 'Fehlende Tabellen zuerst erstellen If InStr(TabTxt, Mid(AC, 3)) = 0 Then Worksheets.Add after:=Worksheets(Sheets.Count) ActiveSheet.Name = Trim(AC) TabTxt = TabTxt & ", " & Trim(AC) End If 'Daten in jede einzelne tabelle kopieren Sht = Trim(AC) lzx = Worksheets(Sht).Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Rows(AC.Row).Copy Worksheets(Sht).Rows(lzx).PasteSpecial xlPasteAll Next AC End With End Sub

Hallo Piet,
erstmal vielen Dank für deinen Code. Habe gestern (noch vor deiner Antwort) einen eher "schwindligen" Code auf die Beine gestellt, der zwar funktioniert aber ca. 10min gebraucht hat. Jetzt habe ich es mal mit Deinem versucht und es hat anfangs nicht funktioniert. Excel ist einfach eingefroren, der Rechner hat aber nicht gearbeitet wie ich im Taskmanager festgestellt habe. Habe das Programm dann im Debugger mit Einzelschritten ausgeführt, da ich ja etliches umschreiben musste. Die Abteilung heißen ja nämlich nicht Abt1 usw. sondern haben Namen wie Controlling Finance etc.. Dachte es liegt daran, dass mein umschreiben falsch war. Stellt sich aber heraus, dass er die Zeilen sehr wohl rüberkopiert, jedoch nach der ersten Zeile jede kopierte Zeile "ausblendet". Sprich man sieht dann links Zeile 2 und darunter Zeile 4. Blendet man Zeile 3 ein, stimmt alles wieder. Führt man den Einzelschritt jetzt aber wieder durch, erscheint wieder eine eingeklappte Zeile. Und solang man sie nicht händisch aufklappt, kann man soviele Einzelschritte machen wie man will, es passiert nichts. - Bzw. stimmt nicht ganz, wenn man dann schon etliche dieser fehlgeschlagenen Einzelschritte durchgeführt hat, danach die Zeile ausklappt und wieder einen durchführt, bekommt man eine kopierte Zeile von viel weiter unten. Dh das Programm arbeitet grundsätzlich richtig aber das mit dem reinkopieren klappt leider nicht.
Würde das File ja gerne hochladen, darf ich aber Datenschutzrechtlich leider nicht - sind sensible Daten.....

Hallo Lisa
okay, Datenschutz muss sein. Ich habe meinen Code noch mal verbessert. So sollte er besser sein.
Herzstück ist die Variabel TabTxt=Tabellen Liste, die zuerst alle vorhanden Tabellen auflistet.
Mit Replace kannst du alle unerwünschten Tabellen die nicht zu kopieren/ löschen sind entfernen.
Das ist wichtig für die nachfolgende Löschfunktion, die ja nicht alle Tabellen löschen soll!!
Neu eingebaut habe ich die Funktion jede kopierte Zeile auf sichtbar zu setzen, und eine StatusBar Anzeige nach jeder 1000sten Kopie. Die Statuszeile kannst du auch löschen, falls nicht gewünscht.
Würde mich freuen wenn der Code so besser klappt. Wie lange dauert es bei 100.000 Zeilen?
mfg Piet


Sub Abteilunen_kopieren()
Dim TabTxt As String, i As Integer
Dim AC As Range, n, lzX, lz1 As Long
Application.ScreenUpdating = False
'vorhandene Tabellen ermitteln
For i = 1 To Worksheets.Count
TabTxt = TabTxt & ", " & Worksheets(i).Name
Next i
'unerwünschte Tabellen löschen
TabTxt = Replace(TabTxt, "diesen Namen löschen", "")
TabTxt = Replace(TabTxt, "jenen Namen löschen", "")
'** vorhandene Tabellen ab Zeile 2 löschen!!  (o. Überschrift)
For i = 1 To Worksheets.Count
If InStr(TabTxt, Worksheets(i).Name) Then
Worksheets(i).Rows("2:" & Rows.Count).Delete
Next i
With Worksheets("Tabelle1")  'Name deiner Liste!!
'LastCell in Tabelle mit Abteilungen
lz1 = .Cells(Rows.Count, 3).End(xlUp).Row
'Alle Daten in einzelne Tabellen kopieren
For Each AC In .Range("C2:C" & lz1)
'** Statusanzeige (kann gelöscht werden!!)
If n >= 1000 Then
Application.ScreenUpdating = True
Application.StatusBar = n & "  Zeile"
Application.ScreenUpdating = False
n = n + 1000
End If
'Fehlende Tabellen zuerst erstellen
If InStr(TabTxt, AC) = 0 Then
Worksheets.Add after:=Worksheets(Sheets.Count)
ActiveSheet.Name = Trim(AC)
TabTxt = TabTxt & ", " & Trim(AC)
End If
'Daten in jede einzelne tabelle kopieren
Sht = Trim(AC):  n = n + 1
lzX = Worksheets(Sht).Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Rows(AC.Row).Copy
Worksheets(Sht).Rows(lzX).PasteSpecial xlPasteAll
Worksheets(Sht).Rows(lzX).EntireRow.Hidden = False
Next AC
End With
End Sub

Sub Aufsplitten() ActiveWorkbook.Worksheets("Probe Quality Testing").Cells.ClearContents ActiveWorkbook.Worksheets("Probe Repair Endosono").Cells.ClearContents Dim c As Range Dim Source As Worksheet Dim Abt1 As Worksheet Dim Abt2 As Worksheet Set Source = ActiveWorkbook.Worksheets("Quelldaten") Set Abt1 = ActiveWorkbook.Worksheets("Abteilung 1") Set Abt2 = ActiveWorkbook.Worksheets("Abteilung 2") For Each c In Source.Range("C1:C" & Source.Cells(Rows.Count, 1).End(xlUp).Row) If c = "Abteilung 1" Then c.EntireRow.Copy Abt1.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues ElseIf c = "Abteilung 2" Then c.EntireRow.Copy Abt2.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues End If Next c Sheets("Quelldaten").Select Rows("1:1").Select Application.CutCopyMode = False Selection.Copy Sheets("Abteilung 1").Select Rows("1:1").Select ActiveSheet.Paste Sheets("Abteilung 2").Select Rows("1:1").Select ActiveSheet.Paste End Sub

Beliebteste Forumthreads (12 Monate)

Ganze Zelle kopieren wenn Text in Zeile

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ganze Zelle kopieren wenn Text in Zeile

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread