Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Makro für Auswahl aus Tabelle und Kopieren in andere Tabellenblätter





Frage

Hallo, brauche dringend Hilfe zu folgendem Problem: ich habe eine Tabelle1 in den Spalten A:P stehen Werte, Text, Datum in der Spalte K steht die Kalenderwoche.zum Beispiel Zeilen 4, 9 und 23 ist Kalenderwoche 8 . Ich möchte nun, das die Zeilen, wo in Spalte K die 8 steht, also 4,9 und 23 zum Beispiel in das Tabellenblatt 8 kopiert wird. Die Zeilen in denen Kalenderwoche 9 in Spalte K steht in das Tabellenblatt 9 usw. Da ich 52 Tabellenblätter habe und die Tabelle 1 sich ständig vergrößert, ist das über Autofilter und Kopieren manuell zu aufwändig. Hat jemand einen Vorschlag, wie man das über ein Makro lösen kann? Mfg Tom

Antwort 1 von nighty

hi all :)

wie gewünscht :))

gruss nighty

Sub suche()
Dim suchen As Long
For suchen = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Cells(suchen, 13) > 1 Then
Sheets(1).Rows(suchen & ":" & suchen).Copy _
Sheets(Cells(suchen, 13)).Rows(Sheets(Cells(suchen, 13)).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":" _
& Sheets(Cells(suchen, 13)).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Sheets(1).Rows(suchen & ":" & suchen).Delete Shift:=xlUp
suchen = suchen - 1
End If
Next suchen
End Sub

Antwort 2 von nighty

hi all :)

korrigiert :))

gruss nighty

Sub suche()
Dim suchen As Long
For suchen = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Cells(suchen, 13) > 1 Then
Sheets(1).Rows(suchen & ":" & suchen).Copy _
Sheets(Cells(suchen, 13) + 1).Rows(Sheets(Cells(suchen, 13)).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":" _
& Sheets(Cells(suchen, 13) + 1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Sheets(1).Rows(suchen & ":" & suchen).Delete Shift:=xlUp
suchen = suchen - 1
End If
Next suchen
End Sub

Antwort 3 von nighty

hi all :)

es wird eine durchgehende namensgebung vorrausgesetzt da das makro nach dem index der sheets geht,es werden 1 - 53 sheets gefordert
1 sheet eingabe mit der spalte m auf abfrage und sheet 2 bis 53 ausgabe

gruss nighty

Antwort 4 von nighty

hi all :)

hier noch eine variante die pflichtfelder beinhaltet von zur zeit A2 B2 C2 M2 nachdem M2 gefuellt worden ist wird die zeile kopiert und anschliessend gelöscht und neu psitioniert,gefordert wie oben 53 sheets,1 sheet eingabe ,2-53 sheet ausgabe

gruss nighty

alt f11/projektexplorer/tabelle1 einfuegen

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim rgBereich As Range
Dim zaehler1 As Range
Set rgBereich = Worksheets("Tabelle1").Range("A2,B2,C2,M2")
For Each zaehler1 In rgBereich
If zaehler1 = "" Then
zaehler1.Select
Exit For
End If
If Cells(2, 13) <> "" Then
Sheets(1).Rows(2 & ":" & 2).Copy _
Sheets(Cells(2, 13) + 1).Rows(Sheets(Cells(2, 13)).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":" _
& Sheets(Cells(2, 13) + 1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Sheets(1).Rows(2 & ":" & 2).Delete Shift:=xlUp
Cells(2, 2).Select
End If
Next zaehler1
End Sub

Antwort 5 von JoeKe

Hi tommu,

mit folgendem Code werden in Tabelle1 (Name muss gegebenenfalls geändert werden) alle Zeilen nacheinander kopiert und in das Tabellenblatt mit dem Namen des Wertes in Spalte K der jeweiligen Zeile eingefügt. Damit es nicht zu doppelten Einträgen kommt, werden die Einträge auf den Blätter 1 - 52 zu beginn gelöscht.

Sub kopieren()
Dim i As Integer, Blatt As String
Application.ScreenUpdating = False
Sheets(Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", _
"16", "17", "18", "19", "20", "21", "22", "23", "24", "52", "25", "26", "27", "28", "29", _
"30", "31", "32", "33", "34", "35", "36", "37", _
"38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52")).Select
Sheets("1").Activate
Cells.Select
Selection.ClearContents
Sheets("Tabelle1").Select
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
On Error Resume Next
Blatt = Sheets("Tabelle1").Cells(i, 11)
Worksheets("Tabelle1").Range("A" & i & ":P" & i).Copy
Sheets(Blatt).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next
End Sub



Mfg

JöKe

Antwort 6 von tommu

Hallo Jöke und nighty,
zuerst mal vielen vielen Dank für eure Hilfe. Das Makro von Jöke funzt super und ist genau das, was ich mir vorgestellt habe. Das Makro von nighty läuft leider nicht. Warum kann ich leider nicht nachvollziehen, da ich als Anfänger den Code nicht verstehe. Vielleicht kannst Du einige Erläuterungen dazu schreiben. Trotzdem vielen Dank.
Mfg
tommu

Antwort 7 von JoeKe

Nabend tommu,

freut mich das du mit meinem Code zurecht gekommen bist. Dank dir für die Rückmeldung.

Schönes WE

JöKe

Antwort 8 von tommu

Hallo Jöke,
hier ist nochmal tommu. Ich habe fesgestellt, das in Tabelle1 in der Spalte A ein Wert stehen muß, sonst wird die Zeile nicht kopiert. Kann man das irgendwie verhindern, bzw. kann ich das Makro so verändern, daß nicht in der Spalte A sondern z.B. in der Spalte E etwas stehen muß?
Mfg
tommu

Antwort 9 von JoeKe

Moin tommu;

ändere diese Zeile:

Zitat:
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

in:
For i = 1 To Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row
Die 11 steht hier für Spalte K.

MfG

JöKe

Antwort 10 von JoeKe

Nachtrag:

Soll in Abhängigkeit einer anderen Spalte kopiert werden, muss die 11 durch den entsprechenden Spaltenindex ersetzt werden.

JöKe

Antwort 11 von JoeKe

Hallo tommu,

sorry habe deine letzte Anfrage wohl ein wenig zu schnell überflogen, deshalb jetzt nochmal genauer.
zu 1. Damit das Makro alles kopiert sobald in Spalte K ein Wert steht muss dies so aussehen:
For i = 1 To Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row
Wenn du zusätzlich die Bedingung einfügen willst, dass in Spalte E ein Wert stehen muss, damit die Zeile auch kopiert werden darf siehr das so aus:
Sub kopieren()
Dim i As Integer, Blatt As String
Application.ScreenUpdating = False
Sheets(Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", _
"16", "17", "18", "19", "20", "21", "22", "23", "24", "52", "25", "26", "27", "28", "29", _
"30", "31", "32", "33", "34", "35", "36", "37", _
"38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52")).Select
Sheets("1").Activate
Cells.Select
Selection.ClearContents
Sheets("Tabelle1").Select
For i = 1 To Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row
On Error Resume Next
Blatt = Sheets("Tabelle1").Cells(i, 11)
If Range("E" & i) <> "" Then
Worksheets("Tabelle1").Range("A" & i & ":P" & i).Copy
Sheets(Blatt).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
End Sub


Bei Fragen meld dich mochmal.

MfG

JöKe