AW: Zeilen mit verschiedenen Probennamen kopieren
04.09.2015 18:34:39
Sebastel
Hallo Benny,
bevor Du noch einmal auf die Nase bekommst, weil Dein Thema angeblich irgendwo doppelt war, hier ein Script, das Dein Problem lösen sollte.
Um es nutzen zu können, machst Du Folgendes:
Öffne ein Kopie(!) Deiner Tabelle mit den Proben und speichere sie im Format Excel-Arbeitsmappe mit Makros (*.xlsm). Im Menü Ansicht / Makros / Pfeil nach unten findest Du den Makrorecorder (Makro aufzeichnen). Starte den Recorder, klicke einmal unten auf den Tab Tabelle2 (oder eine andere) und beende den Recorder wieder.
Anschließend öffnest Du wieder das Makro-Menü, wählst Makro anzeigen, Makro1 bearbeiten und erhälst den VBA-Code Deines Miniatur-Makros. Diesen löscht Du komplett und ersetzt ihn durch folgenden Code:
Sub Makro_Proben_Auszug()
' Bildschirmausgabe vorübergehend ausschalten (verhindert unnötiges Bildschirmgeflacker)
Application.ScreenUpdating = False
'' Tabelle2 leeren und Formatierung entfernen
Sheets("Tabelle2").Select
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.Value = ""
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
'' Suchbegriffe in Tabelle3 auswählen
Sheets("Tabelle3").Select
' Variablendeklaration
Dim strProbe As String
Dim intProbe As Integer
'Letzte belegte Zelle in Spalte A finden
Cells(65000, 1).End(xlUp).Offset(0, 0).Select
' Schleifenzähler definieren
intProbe = ActiveCell.Row
' Schleife mit drei Aufgaben durchlaufen
For i = 1 To intProbe
strProbe = Cells(i, 1)
' MsgBox strProbe, , "Zeile " & i
'' Aufgabe 1: Auffinden des Suchbegriffs in Tabelle1
' Variablendeklaration
Dim intZeile, intSpalte As Integer
Dim strAuszug As String
Sheets("Tabelle1").Select
Range("B1").Select
Cells.Find(What:=strProbe, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'Zelladresse in Range übertragen und kopieren
intZeile = ActiveCell.Row
intSpalte = 27
Range(Cells(intZeile, 1), (Cells(intZeile, intSpalte))).Select
Selection.Copy
'' Aufgabe 2: Kopieren der Zeilen nacheinander in Tabelle2
Sheets("Tabelle2").Select
Cells(i, 1).Select
ActiveSheet.Paste
'' Aufgabe 3: Aktivieren der Tabelle 3
Sheets("Tabelle3").Select
' nächsten Schleifendurchlauf aufrufen
Next i
' Schleife beendet
' Cursor positionieren
Sheets("Tabelle1").Select
Cells(1.1).Select
Sheets("Tabelle3").Select
Cells(1.1).Select
' Bildschirm wieder aktualisieren
Application.ScreenUpdating = True
' Abschlussausgabe
Sheets("Tabelle2").Activate
Cells(1.1).Select
MsgBox (i - 1) & " Proben in Tabelle 2 geschrieben", , "Erfolgreich!"
End Sub
WICHTIG: Sollten in Deiner Arbeitsmappe keine drei Tabellen vorhanden sein oder diese andere Namen haben, musst Du entweder soviele Tabllen einfügen, dass tatsächlich drei zur Verfügung stehen, oder die Namen der "Tabelle1" ... im VBA-Code an Deine Tabelle anpassen. Einfachste und sicherste Methode ist STRG+H (Suchen und Ersetzen)
Anschließend kannst Du das Makro_Proben_Auszug über das Makromenü starten.
Was musst in Deiner Tabelle dazu tun?
1.) müssen die erforderlichen Probennamen in die Spalte A der Tabelle3 eingetragen sein.
2.) dürfen die Tabelle2 und ...3 nicht anderweitig verwendet werden.
3.) dürfen die in der Original-Tabelle angelegten Spalten nicht über die Spalte AB hinausgehen.
Dann sollte alles funktionieren ...
Schöne Grüße
Sebastel
p.s. Ich habe versucht den VBA-Code möglichst so zu kommentieren, dass er in seiner Logik nachvollziehbar ist. Alle Zeilen, die mit einem ' anfangen, sind solche Kommentare
p.p.s. Ich freue mich über jede Rückmeldung ...