Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1184to1188
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

Beitrag vom 12.11.

Beitrag vom 12.11.
Günter
Guten Morgen,
am 12.11. hatte Josef Ehrensberger eine interessante VBA-Lösung
für Willi.
Gibt es die Möglichkeit, dass in der Haupttabelle die Einträge automatisch
gelöscht werden, welche "umgesetzt" wurden. Also in ein eigenes Arbeitsblatt
kopiert wurden.
Schönen Gruß
Günter
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub CommandButton1_Click()
Dim objSh As Worksheet
Dim lngLast As Long, lngRow As Long
On Error GoTo ErrExit
Application.ScreenUpdating = False
With Me
lngLast = Application.Max(2, .Cells(Rows.Count, 8).End(xlUp).Row)
For lngRow = 2 To lngLast
If .Cells(lngRow, 8)  "" Then
If SheetExist(.Cells(lngRow, 8).Text) Then
Set objSh = Sheets(.Cells(lngRow, 8).Text)
Else
Set objSh = Worksheets.Add(after:=Sheets(Sheets.Count))
objSh.Name = .Cells(lngRow, 8).Text
End If
.Rows(lngRow).Copy objSh.Cells(Application.Max(2, objSh.Cells(objSh.Rows.Count, 8).End( _
xlUp).Row + 1), 1)
End If
Next
sortSheets
.Move before:=Sheets(1)
End With
ErrExit:
Application.ScreenUpdating = True
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
Sub sortSheets(Optional Order As XlSortOrder = xlAscending, Optional AlphaNumeric As Boolean = True)
Dim lngA As Integer, lngB As Integer
With ActiveWorkbook
For lngA = 1 To .Sheets.Count
For lngB = 1 To .Sheets.Count - 1
If Format(UCase$(.Sheets(lngB + IIf(Order = xlAscending, 0, 1)).Name), _
IIf(AlphaNumeric, "000000000", "@")) > Format(UCase$(.Sheets(lngB + _
IIf(Order = xlAscending, 1, 0)).Name), IIf(AlphaNumeric, _
"000000000", "@")) Then
.Sheets(lngB).Move after:=.Sheets(lngB + 1)
End If
Next
Next
End With
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Beitrag vom 12.11.
17.11.2010 20:56:23
Josef

Hallo Günter,
das geht z.B. so.

Private Sub CommandButton1_Click()
  Dim objSh As Worksheet, rng As Range
  Dim lngLast As Long, lngRow As Long
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  With Me
    lngLast = Application.Max(2, .Cells(Rows.Count, 8).End(xlUp).Row)
    
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 8) <> "" Then
        If SheetExist(.Cells(lngRow, 8).Text) Then
          Set objSh = Sheets(.Cells(lngRow, 8).Text)
        Else
          Set objSh = Worksheets.Add(after:=Sheets(Sheets.Count))
          objSh.Name = .Cells(lngRow, 8).Text
        End If
        .Rows(lngRow).Copy objSh.Cells(Application.Max(2, objSh.Cells(objSh.Rows.Count, _
          8).End(xlUp).Row + 1), 1)
        If rng Is Nothing Then
          Set rng = .Rows(lngRow)
        Else
          Set rng = Union(rng, .Rows(lngRow))
        End If
      End If
    Next
    sortSheets
    .Move before:=Sheets(1)
  End With
  
  If Not rng Is Nothing Then rng.Delete
  
  ErrExit:
  Application.ScreenUpdating = True
  Set objSh = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Beitrag vom 12.11.
18.11.2010 06:46:25
Günter
Guten Morgen,
vielen Dank Josef.
Bin gleich freudig am Testen.
Gruß
Günter
AW: Beitrag vom 12.11.
18.11.2010 07:56:04
Günter
Super Josef,
hat funktioniert -was ich auch garnicht bezweifelt hatte-.
Danke nochmal und einen schönen Tag.
Gruß
Günter

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige