Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1184to1188
1184to1188
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Tabellenblatt kopieren wenn voll

Forumthread: Tabellenblatt kopieren wenn voll

Tabellenblatt kopieren wenn voll
jens
Hallo Excel-Profis,
ich habe ein Problem mit einem Makro bzw. dem kopieren von Daten.
Es werden per Makro jede Sekunde Daten in ein Blatt "Daten" übertragen.
Irgendwann sind die 65.000 Zeilen aber voll (es werden immer 20 Datensätze übertragen) - dann sollte das Makro die Tabelle "Daten" kopieren (in "Daten (1)"... und das Blatt Daten von Zeile 2:65000 wieder löschen.
Lann man das per Makro machen?
Vielen Dank und viele Grüße Jens
Anzeige
AW: Tabellenblatt kopieren wenn voll
13.11.2010 19:57:03
Josef

Hallo Jens,
klar geht das, aber wieso zeigst du nicht den Code, dann kann man es direkt integrieren.

Gruß Sepp

Anzeige
AW: Tabellenblatt kopieren wenn voll
13.11.2010 20:00:51
jens
Hallo Sepp,
vielen Dank für die Rückmeldung - hier der Code:
Sub Uebertragen()
Application.ScreenUpdating = False
Sheets("Tabelle1").Select
Range("H3").Select
Dim R As Range
Set R = Range("J11:CS30")
If Range("J11").Text  "Leerdatensatz" Then
If Application.CountIf(Range("J11:CR30"), "Leerdatensatz") > 0 Then
Set R = Range("J11:CS" & Application.Match("Leerdatensatz", Range("J11:CS30"), 0) + 2)
End If
End If
R.Select
Selection.Copy
Sheets("Daten").Cells(IIf(Len(Sheets("Daten").Cells(2, 1)) = 0, 2, IIf(Len(Sheets("Daten"). _
Cells(3, 1)) = 0, 3, Sheets("Daten").Cells(2, 1).End(xlDown).row + 1)), 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Tabelle1").Select
Range("H3").Select
Application.ScreenUpdating = True
End Sub

Viele Grüße Jens
Anzeige
AW: Tabellenblatt kopieren wenn voll
13.11.2010 20:19:02
Josef

Hallo Jens,
probier mal so, ist allerdings ungetestet.

Sub Uebertragen()
  Dim rng As Range
  Dim lngRow As Long
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  With Sheets("Tabelle1")
    If .Range("J11").Text <> "Leerdatensatz" Then
      If Application.CountIf(.Range("J11:CR30"), "Leerdatensatz") > 0 Then
        Set rng = .Range("J11:CS" & Application.Match("Leerdatensatz", .Range("J11:CS30"), 0) + 2)
      End If
    End If
  End With
  
  If Not rng Is Nothing Then
    With Sheets("Daten")
      lngRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
      If lngRow + rng.Rows.Count > .Rows.Count Then
        .Copy After:=Sheets(Sheets.Count)
        .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
        lngRow = 2
      End If
      .Cells(lngRow, 1).Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
    End With
  End If
  
  ErrExit:
  Application.ScreenUpdating = True
End Sub

Gruß Sepp

Anzeige
AW: Tabellenblatt kopieren wenn voll
14.11.2010 13:37:00
jens
Hallo Sepp,
vielen Dank, der Code sieht besser aus - ich bin leider Selektierer...
Aber er überträgt gar nichts - warum?
Ich habe mal eine Beispieldatei hochgeladen. https://www.herber.de/bbs/user/72286.xls
Vielen Dank und noch einen schönen Sonntag.
Viele Grüße Jens
Anzeige
AW: Tabellenblatt kopieren wenn voll
14.11.2010 14:51:31
Josef

Hallo Jens,
das sollte klappen. (der Teil mit Application.Match(...) hat bei mir nicht funktioniert, hab das etwas umgebaut!)

Sub Uebertragen()
  Dim rng As Range, rngF As Range
  Dim lngRow As Long
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  With Sheets("Tabelle1")
    If .Range("J11").Text <> "Leerdatensatz" Then
      Set rngF = .Range("J11:CR30").Find(What:="Leerdatensatz", LookAt:=xlPart, LookIn:=xlValues)
      If Not rngF Is Nothing Then
        Set rng = .Range("J11:CS" & rngF.Row + 2)
      Else
        Set rng = .Range("J11:CS30")
      End If
    End If
  End With
  
  If Not rng Is Nothing Then
    With Sheets("Daten")
      lngRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
      If lngRow + rng.Rows.Count > .Rows.Count Then
        .Copy After:=Sheets(Sheets.Count)
        .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
        lngRow = 2
      End If
      .Cells(lngRow, 1).Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
    End With
  End If
  
  ErrExit:
  Application.ScreenUpdating = True
  
  Set rngF = Nothing
  Set rng = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Tabellenblatt kopieren wenn voll
14.11.2010 15:41:23
jens
Hallo Sepp,
vielen Dank - es geht, aber es gibt ein kleines Problem:
Der Rechner steht für ca. 4 Minuten!
Das liegt warscheinlich am kopieren des Blattes - mit dem ganzen Inhalt.
Mir fällt als Lösung folgendes ein:
Nicht kopieren sondern umbenennen.
Dann lasse ich in der Datei ein Blatt Daten_leer stehen welches man in das Blatt "Daten" kopiert (sollte schnell gehen weil es ja nur Zeile 1 gefüllt hat)
Geht das?
Viele Grüße Jens
Anzeige
AW: Tabellenblatt kopieren wenn voll
14.11.2010 16:34:23
Josef

Hallo Jens,
klar geht das, du brauchst auch kein Blatt auf "Vorrat" halten.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Uebertragen()
  Dim rng As Range, rngF As Range
  Dim lngRow As Long, lngIndex As Long
  Dim objSh As Worksheet
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  Set objSh = Sheets("Daten")
  
  With Sheets("Tabelle1")
    If .Range("J11").Text <> "Leerdatensatz" Then
      Set rngF = .Range("J11:CR30").Find(What:="Leerdatensatz", LookAt:=xlPart, LookIn:=xlValues)
      If Not rngF Is Nothing Then
        Set rng = .Range("J11:CS" & rngF.Row + 2)
      Else
        Set rng = .Range("J11:CS30")
      End If
    End If
  End With
  
  If Not rng Is Nothing Then
    With Sheets("Daten")
      lngRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
      If lngRow + rng.Rows.Count > .Rows.Count Then
        Do
          lngIndex = lngIndex + 1
          If Not SheetExist("Daten (" & lngIndex & ")") Then
            .Name = "Daten (" & lngIndex & ")"
            Exit Do
          End If
        Loop
        Set objSh = ThisWorkbook.Worksheets.Add(Before:=objSh)
        objSh.Name = "Daten"
        Sheets("Daten (" & lngIndex & ")").Rows(1).Copy objSh.Cells(1, 1)
        lngRow = 2
      End If
      .Cells(lngRow, 1).Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
    End With
  End If
  
  ErrExit:
  Application.ScreenUpdating = True
  
  Set rngF = Nothing
  Set rng = Nothing
  Set objSh = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

Anzeige
AW: Tabellenblatt kopieren wenn voll
14.11.2010 18:10:55
jens
Hi Sepp,
klasse, das funzt in einer Sekunde - was so was doch ausmachen kann. Obwohl es ja das gleiche macht wie das letzte Makro.
Tausend Dank, ich wünsche Dir noch einen schönen Sonntag und einen guten Start in die Woche.
Viele dankbare Grüße Jens

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige