Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1260to1264
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

Zeilen automatisch in Tabellenblätter kopieren

Zeilen automatisch in Tabellenblätter kopieren
Tim
Hallo,
folgendes Makro erstellt mir Automatisch neue Tabellenblätter, in Abhängigkeit der in Spalte A eingetragenen Werte. Dieses möchte ich jetzt so erweitern, dass alle Zeilen, deren Werte in A mit den Bezeichnungen der Tabellenblätter übereinstimmen, automatisch in die entsprechenden Blätter eingefügt werden. Da es immer verschiedene und sehr viele Tabellenblätter geben wird, möchte ich die Bezeichnung der Blätter nicht im Code vorgeben... Ich hoffe, jmd. hat eine Idee. Vielen Dank.
Tim
Sub neueBlätter()
Dim objSh As Worksheet
Dim rng As Range
With ActiveSheet
For Each rng In Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If Len(rng) Then
If IsValidSheetName(rng.Text) Then
If Not SheetExist(rng.Text) Then
Set objSh = .Parent.Worksheets.Add(After:=.Parent.Sheets(.Parent.Sheets.Count))
objSh.Name = rng.Text
End If
End If
End If
Next
End With
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
Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
.IgnoreCase = True
IsValidSheetName = .test(strName)
End With
Set objRegExp = Nothing
End Function

AW: Zeilen automatisch in Tabellenblätter kopieren
22.04.2012 12:10:10
Josef

Hallo Tim,
Sub neueBlätter()
  Dim objSh As Worksheet
  Dim rng As Range
  
  With ActiveSheet
    For Each rng In Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
      If Len(rng) Then
        If IsValidSheetName(rng.Text) Then
          If Not SheetExist(rng.Text) Then
            Set objSh = .Parent.Worksheets.Add(After:=.Parent.Sheets(.Parent.Sheets.Count))
            objSh.Name = rng.Text
          Else
            Set objSh = Sheets(rng.Text)
          End If
          rng.EntireRow.Copy objSh.Cells(objSh.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
      End If
    Next
  End With
End Sub



« Gruß Sepp »

Anzeige
AW: Zeilen automatisch in Tabellenblätter kopieren
22.04.2012 17:34:20
Tim
Hallo Josef,
vielen Dank klappt wunderbar.
Allerdings werden jetzt hinterlegte Formeln mit kopiert, ich bräuchte aber nur die Zellen-Werte...
Danke :)
AW: Zeilen automatisch in Tabellenblätter kopieren
22.04.2012 17:37:46
Josef

Hallo Tim,
das solltest du halt auch mitteilen!
Sub neueBlätter()
  Dim objSh As Worksheet
  Dim rng As Range
  
  With ActiveSheet
    For Each rng In Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
      If Len(rng) Then
        If IsValidSheetName(rng.Text) Then
          If Not SheetExist(rng.Text) Then
            Set objSh = .Parent.Worksheets.Add(After:=.Parent.Sheets(.Parent.Sheets.Count))
            objSh.Name = rng.Text
          Else
            Set objSh = Sheets(rng.Text)
          End If
          objSh.Cells(objSh.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow = rng.EntireRow.Value
        End If
      End If
    Next
  End With
End Sub



« Gruß Sepp »

Anzeige
AW: Zeilen automatisch in Tabellenblätter kopieren
22.04.2012 20:23:34
Tim
Sorry,
jetzt ist alles prima :)
DANKE
AW: Zeilen automatisch in Tabellenblätter kopieren
23.04.2012 17:16:15
Tim
Hi Josef,
ich muss doch nochmal was fragen...
Wenn ich die kopierten Daten jeweils erst beginnend mit der 5ten Zeile einfügen möchte, wie muss ich dann den Code abändern?
Wenn ich Offset(5, 0), statt Offset(1, 0). benutze, werden ja jeweils 5 Zeilen freigelassen....
Danke!!!
AW: Zeilen automatisch in Tabellenblätter kopieren
23.04.2012 19:25:40
Josef

Hallo Tim,
Sub neueBlätter()
  Dim objSh As Worksheet
  Dim rng As Range
  
  With ActiveSheet
    For Each rng In Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
      If Len(rng) Then
        If IsValidSheetName(rng.Text) Then
          If Not SheetExist(rng.Text) Then
            Set objSh = .Parent.Worksheets.Add(After:=.Parent.Sheets(.Parent.Sheets.Count))
            objSh.Name = rng.Text
          Else
            Set objSh = Sheets(rng.Text)
          End If
          objSh.Cells(Application.Max(5, objSh.Cells(objSh.Rows.Count, 1).End(xlUp).Row + 1), 1).EntireRow = rng.EntireRow.Value
        End If
      End If
    Next
  End With
End Sub




« Gruß Sepp »

Anzeige
AW: Zeilen automatisch in Tabellenblätter kopieren
23.04.2012 19:34:39
Tim
Tausend Dank!!!

309 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige