Supportnet / Forum / Tabellenkalkulation

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

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

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

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

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

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

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

Nabend tommu,

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

Schönes WE

JöKe

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

Moin tommu;

ändere diese Zeile:


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

Nachtrag:

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

JöKe

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

• Ausblenden und Einblenden von Tabellenblättern
• Makro speichern
• Excel VBA -- Tabellenblätter auswählen und drucken
• Makro für alle Tabellenblätter verfügbar machen
• Tabelle ohne ausgeblendeten Text kopieren in andere Tabelle