Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1144to1148
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zeile einfügen und kopieren

Zeile einfügen und kopieren
Matthias
Hallo zusammen,
ich habe wieder mal ein kleines Problem und komme nicht ganz zurecht damit.
Ich habe ein Tabellenblatt mit z.Zt. knapp 4000 Einträgen (Zeilen) und mehreren Spalten (Spalten A bis AB).
Jetzt will ich irgendwo eine neue Zeile einfügen, dabei sollte der Inhalt von einigen Zellen (nicht allen), die oberhalb der eingefügten Zeile liegen, in die neue kopiert werden, bzw. gewisse spezielle Angaben hinein geschrieben werden.
Die Spalte A beinhaltet eine fortlaufende Nummerierung, zur Zeit 1-3843, wird natürlich immer mehr.
Also:
1. ich aktiviere irgendwo eine Zelle (manuell, mit der Maus)
2. jetzt lasse ich einen Code ablaufen, der folgendes machen sollte:
- eine neue Zeile unterhalb der akiven Zelle einfügen
- aus der oberen Zeile (die, mit der aktivierten Zelle) werden nun die Inhalte aus den folgenden Zellen in die neue Zeile kopiert: B-F, H-J, U-V
- folgende Zellen sollen leer bleiben: G, K-T; AB
- in der Zelle A soll die nächstfolgende Nummer geschrieben werden (also 3844)
- in der Zelle Y soll immer das Wort "Neu" geschrieben werden
- in den beiden Zellen Z und AA soll das aktuelle Datum eingetragen werden
Die zu kopierenden Werte sind teils reine Zahlen, teils aber auch Formeln. Bei den Formeln muss dann die gleiche Formel mit den entsprechenden Anpassungen (Zeile/Spalte) kopiert werden.
Das Ganze muss dann auch funktionieren, wenn diverse Spalten durch die Gruppierung nicht sichtbar sind und/oder wenn die Anzeige der Daten mit dem AutoFilter reduziert wurde.
Gibt es dafür eine Lösung?
Schon mal besten Dank im Voraus und einen schönen Tag!
Matthias

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

Betreff
Benutzer
Anzeige
AW: Zeile einfügen und kopieren
12.03.2010 07:32:25
Josef

Hallo Matthias,
probier mal.

Sub insertRow()
  Dim lngRow As Long
  With ActiveSheet
    lngRow = ActiveCell.Row
    If .Cells(lngRow, 1) > 0 Then
      .Rows(lngRow).Copy
      .Rows(lngRow + 1).Insert
      Application.CutCopyMode = False
      .Cells(lngRow + 1, 1) = Application.Max(.Columns(1)) + 1
      .Cells(lngRow + 1, 25) = "Neu"
      .Cells(lngRow + 1, 26) = Date
      .Cells(lngRow + 1, 27) = Date
      Union(.Cells(lngRow + 1, 7), .Range(.Cells(lngRow + 1, 7), _
        .Cells(lngRow + 1, 11)), .Cells(lngRow + 1, 28)) = ""
    End If
  End With
End Sub

Gruß Sepp

Anzeige
AW: Zeile einfügen und kopieren
12.03.2010 08:49:25
Matthias
Hallo Sepp,
ganz herzlichen Dank! Funktioniert schon (fast) perfekt! Habe noch eine Kleinigkeit geändert (Range... ist nicht von 7-11, sondern 11-20).
Nun gibt es aber noch eine Einschränkung:
Wenn die Darstellung der Daten im Tabellenblatt mit BEIDEN (Gruppierung + AutoFilter) reduziert wurde, werden nicht mehr alle Zellen kopiert, nur noch die 1. und die 3 letzten (1, 25, 26, 27). Sobald nur eine der beiden Funktionen aktiv ist, ist es ok.
AW: Zeile einfügen und kopieren
12.03.2010 09:10:05
Josef

Hallo Matthias,
dann so.

Sub insertRow()
  Dim lngRow As Long
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  ThisWorkbook.CustomViews.Add "xxxView", True, True
  With ActiveSheet
    If .AutoFilterMode Then .Range("A1").AutoFilter
    .Range("A1").CurrentRegion.ClearOutline
    lngRow = ActiveCell.Row
    If .Cells(lngRow, 1) > 0 Then
      .Rows(lngRow).Copy
      .Rows(lngRow + 1).Insert
      Application.CutCopyMode = False
      .Cells(lngRow + 1, 1) = Application.Max(.Columns(1)) + 1
      .Cells(lngRow + 1, 25) = "Neu"
      .Cells(lngRow + 1, 26) = Date
      .Cells(lngRow + 1, 27) = Date
      Union(.Cells(lngRow + 1, 7), .Range(.Cells(lngRow + 1, 11), _
        .Cells(lngRow + 1, 20)), .Cells(lngRow + 1, 28)) = ""
    End If
  End With
  
  With ThisWorkbook.CustomViews("xxxView")
    .Show
    .Delete
  End With
  ErrExit:
  Application.ScreenUpdating = True
End Sub

Gruß Sepp

Anzeige
nochmals angepasst.
12.03.2010 09:32:20
Josef

Hallo Matthias,
so sollte es jetzt laufen.

Sub insertRow()
  Dim lngRow As Long
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  ThisWorkbook.CustomViews.Add "xxxView", True, True
  With ActiveSheet
    If .AutoFilterMode Then .Range("A1").AutoFilter
    .Outline.ShowLevels 3, 3
    lngRow = ActiveCell.Row
    If .Cells(lngRow, 1) > 0 Then
      .Rows(lngRow).Copy
      .Rows(lngRow + 1).Insert
      Application.CutCopyMode = False
      .Cells(lngRow + 1, 1) = Application.Max(.Columns(1)) + 1
      .Cells(lngRow + 1, 25) = "Neu"
      .Cells(lngRow + 1, 26) = Date
      .Cells(lngRow + 1, 27) = Date
      Union(.Cells(lngRow + 1, 7), .Range(.Cells(lngRow + 1, 11), _
        .Cells(lngRow + 1, 20)), .Cells(lngRow + 1, 28)) = ""
    End If
  End With
  
  With ThisWorkbook.CustomViews("xxxView")
    .Show
    .Delete
  End With
  ErrExit:
  Application.ScreenUpdating = True
End Sub

Gruß Sepp

Anzeige
AW: nochmals angepasst.
12.03.2010 10:30:00
Matthias
Hallo Sepp,
ja, so läuft es jetzt perfekt, genau so wie ich es mir vorgestellt habe!
Noch eine kleine Frage:
wie kann ich schnell mal im Code die "nicht zu kopierenden" Zellen erweitern? Also, ich möchte z.B. noch zusätzlich Spalte "W und X" oder nur "W" oder "B und D" (nicht nebeneinander liegend) einbeziehen.
Habe schon mit der Codezeile "Union..." probiert, aber das will nicht so ganz.
Gruss
Matthias
AW: nochmals angepasst.
12.03.2010 11:02:43
Josef

Hallo Matthias,
das ist schon richtig, ich habe es jetzt umgestellt damit es übersichtlicher wird, siehe Kommentar.

Sub insertRow()
  Dim lngRow As Long, lngCol As Long
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  ThisWorkbook.CustomViews.Add "xxxView", True, True
  With ActiveSheet
    If .AutoFilterMode Then .Range("A1").AutoFilter
    .Outline.ShowLevels 3, 3
    lngRow = ActiveCell.Row
    If .Cells(lngRow, 1) > 0 And lngRow > 1 Then
      .Rows(lngRow).Copy
      lngRow = lngRow + 1
      .Rows(lngRow).Insert
      Application.CutCopyMode = False
      .Cells(lngRow, 1) = Application.Max(.Columns(1)) + 1
      .Cells(lngRow, 25) = "Neu"
      .Cells(lngRow, 26) = Date
      .Cells(lngRow, 27) = Date
      For lngCol = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
        Select Case lngCol
          Case 2, 7, 11 To 20, 28 'hier die zu löschenden Spalten angeben
            'zusammenhängende in der Form x to xx!
            .Cells(lngRow, lngCol) = ""
        End Select
      Next
    End If
  End With
  
  With ThisWorkbook.CustomViews("xxxView")
    .Show
    .Delete
  End With
  ErrExit:
  Application.ScreenUpdating = True
End Sub

Gruß Sepp

Anzeige
AW: nochmals angepasst.
12.03.2010 11:28:35
Matthias
Hallo Sepp,
jetzt ist es perfekt!
Ganz herzlichen Dank für Deine Bemühungen!
Ich wäre froh, wenn ich das auch hin bekommen würde...
Ein schönes Wochenende und Liebe Grüsse!
Matthias
AW: Zeile einfügen und kopieren
12.03.2010 08:00:20
Uwe
Hallo Matthias,
der Code muss in das VBA-Modul der entsprechenden Tabelle und wird
ausgeführt bei Doppelklick in eine Zelle:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim rngZeile As Range
Target.EntireRow.Copy
Target.Offset(1).EntireRow.Insert
Application.CutCopyMode = False
Set rngZeile = Target.Offset(1).EntireRow
With rngZeile
.Range("A1").Value = Application.WorksheetFunction.Max(.Range("A1").EntireColumn) + 1
.Range("G1,K1:T1,AB1") = ""
.Range("Y1").Value = "Neu"
.Range("Z1:AA1").Value = Date
End With
End Sub
Gruß Uwe
Anzeige
AW: Zeile einfügen und kopieren
12.03.2010 10:18:52
Matthias
Hallo Uwe,
danke für Deine Bemühungen! Auch Dein Code läuft tiptop, ist aber das gleiche Problem wie beim anderen Code vom Sepp (bei gleichzeitiger Aktivierung von AutoFilter + Gruppierung werden die Zellen nicht mehr kopiert.
Das mit dem Doppelklick ist auch eine gute Idee, mal sehen, was sich durchsetzen wird...
Gruss
Matthias

351 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige