mal wieder makros

Dieses Thema mal wieder makros im Forum "Microsoft Office Suite" wurde erstellt von pengo, 26. Apr. 2005.

Thema: mal wieder makros serv @all, weis net ob das hier her gehört! schreit wenns falsch ist! diese makro läuft bei mir net. ich habe...

  1. serv @all,

    weis net ob das hier her gehört! schreit wenns falsch ist!

    diese makro läuft bei mir net.

    ich habe von dem ganzen keine ahnung wird wahrscheinlich ziemlich leicht gehen es zum laufen zu bringen. wenn man weis wies geht!

    getestet auf office 2003 und 2002.

    code:

    Option Explicit

    Private Const DONT_SHOW = (
    Private Const CELL_PAPER_TYPE = C3
    Private Const CELL_COL_FIRST_DATE = 2
    Private Const LIST_HEIGHT = 300
    Private Const INDEX_NAME = 1
    Private Const INDEX_TYPE = 2

    Sub DisplaySheet(SheetName As String)
    On Error GoTo SheetError
    Dim LastRow As Integer
       
       Sheets(SheetName).Select
       LastRow = ActiveSheet.Cells(Rows.Count, CELL_COL_FIRST_DATE).End(xlUp).Row + 1
       ActiveSheet.Cells(LastRow, CELL_COL_FIRST_DATE).Select
             
    SheetError:
    End Sub

    Sub GoToMenu()
        Menu.Select
    End Sub

    Sub Initialize()
    Dim Sheet As Worksheet
    Dim SheetNameArray() As String
    Dim Index As Integer
       
       Menu.SheetList.Clear
       Menu.SheetList.ColumnCount = 2
       Menu.SheetList.ColumnWidths = 60;
       
       ReDim SheetNameArray(1 To Sheets.Count - GetNoShowCount, 1 To 2)
       
       Index = 1
       For Each Sheet In Sheets
          If Left(Sheet.Name, 1) <> DONT_SHOW Then
             SheetNameArray(Index, INDEX_NAME) = Sheet.Name
             SheetNameArray(Index, INDEX_TYPE) = Sheet.Range(CELL_PAPER_TYPE).Text
             Index = Index + 1
          End If
       Next
       
       Sort2D SheetNameArray
       
       Menu.SheetList.List() = SheetNameArray()
       Menu.SheetList.Height = LIST_HEIGHT
    End Sub
    Sub Neu()
    '
    ' Neu Makro
    ' Makro am 11.08.2003 von * aufgezeichnet
    '

    '
    Dim Mldg, Titel, Voreinstellung, Wert1
    Mldg = Nummer
    Titel = Nummer eingeben
    Voreinstellung = 9999
    Wert1 = InputBox(Mldg, Titel, Voreinstellung)
    If Wert1 = Then Exit Sub
    ActiveWorkbook.Worksheets((Papier_Basis)).Copy Before:=Worksheets((Papier_Basis))
    ActiveSheet.Name = Wert1

    End Sub


    Private Function GetNoShowCount() As Integer
    Dim Sheet As Worksheet
       
       GetNoShowCount = 0
       For Each Sheet In Sheets
          If Left(Sheet.Name, 1) = DONT_SHOW Then
             GetNoShowCount = GetNoShowCount + 1
          End If
       Next
    End Function

    Private Sub Sort2D(ByRef AnArray)
    Dim Index As Integer
    Dim Temp() As String
    Dim SwapCount As Integer

    SwapCount = 1
    Do Until SwapCount = 0
        SwapCount = 0
        For Index = 1 To UBound(AnArray) - 1
            If AnArray(Index, INDEX_NAME) > AnArray(Index + 1, INDEX_NAME) Then
                Temp() = AnArray(Index + 1)
                AnArray(Index + 1) = AnArray(Index)
                AnArray(Index) = Temp()
                SwapCount = SwapCount + 1
            End If
        Next
    Loop
    End Sub

    :code
     
  2. Hi pengo,

    bei Menu.SheetList bin ich etwas ratlos. Hab das einfach durch eine Userform->Userform1' und eine daraufliegende Listbox->Listbox1' ersetzt.
    Mit den dann vorgenommenen Änderungen gibt das Makro Initialize dann die Liste der Tabellenblätter und den Inhalt von C3 des jeweiligen tabellenblattes aus.

    Das eigentliche Problem ist in Sort2D das Feld Temp(). Das wird jetzt entsprechend dimensioniert und übergeben.

    Ein Weiteres Problem liegt in der Zuweisung Menu.SheetList.List() = SheetNameArray(). Hier Muß der Typ von SheetNameArray auf Variant geändert werden, weil Listenfelder eben diesen Typ erwarten.

    Gruß Matjes :)

    Code:
    Option Explicit
    
    Private Const DONT_SHOW = (
    Private Const CELL_PAPER_TYPE = C3
    Private Const CELL_COL_FIRST_DATE = 2
    Private Const LIST_HEIGHT = 300
    Private Const INDEX_NAME = 1
    Private Const INDEX_TYPE = 2
    
    Sub DisplaySheet(SheetName As String)
    On Error GoTo SheetError
    Dim LastRow As Integer
       
       Sheets(SheetName).Select
       LastRow = ActiveSheet.Cells(Rows.Count, CELL_COL_FIRST_DATE).End(xlUp).Row + 1
       ActiveSheet.Cells(LastRow, CELL_COL_FIRST_DATE).Select
             
    SheetError:
    End Sub
    
    'Sub GoToMenu()
    '    Menu.Select
    'End Sub
    
    Sub Initialize()
    Dim Sheet As Worksheet
    Dim SheetNameArray() As Variant
    Dim Temp() As Variant
    Dim Index As Integer
       
       Load UserForm1
       UserForm1.ListBox1.Clear
       UserForm1.ListBox1.ColumnCount = 2
       UserForm1.ListBox1.ColumnWidths = 60;
       
       ReDim SheetNameArray(1 To Sheets.Count - GetNoShowCount, 1 To 2)
       ReDim Temp(1 To 1, 1 To 2)
       
       Index = 1
       For Each Sheet In Sheets
          If Left(Sheet.Name, 1) <> DONT_SHOW Then
             SheetNameArray(Index, INDEX_NAME) = Sheet.Name
             SheetNameArray(Index, INDEX_TYPE) = Sheet.Range(CELL_PAPER_TYPE).Text
             Index = Index + 1
          End If
       Next
       
       Call Sort2D(SheetNameArray(), Temp())
       
       UserForm1.ListBox1.List() = SheetNameArray()
       UserForm1.ListBox1.Height = LIST_HEIGHT
       UserForm1.Show
       ReDim SheetNameArray(1 To 1, 1 To 2)
    End Sub
    Sub Neu()
    '
    ' Neu Makro
    ' Makro am 11.08.2003 von * aufgezeichnet
    '
    
    '
    Dim Mldg, Titel, Voreinstellung, Wert1
    Mldg = Nummer
    Titel = Nummer eingeben
    Voreinstellung = 9999
    Wert1 = InputBox(Mldg, Titel, Voreinstellung)
    If Wert1 =  Then Exit Sub
    ActiveWorkbook.Worksheets((Papier_Basis)).Copy Before:=Worksheets((Papier_Basis))
    ActiveSheet.Name = Wert1
    
    End Sub
    
    
    Private Function GetNoShowCount() As Integer
    Dim Sheet As Worksheet
       
       GetNoShowCount = 0
       For Each Sheet In Sheets
          If Left(Sheet.Name, 1) = DONT_SHOW Then
             GetNoShowCount = GetNoShowCount + 1
          End If
       Next
    End Function
    
    Private Sub Sort2D(ByRef AnArray(), ByRef Temp())
    Dim Index As Integer
    Dim SwapCount As Integer
    
    SwapCount = 1
    Do Until SwapCount = 0
        SwapCount = 0
        For Index = 1 To UBound(AnArray) - 1
            If AnArray(Index, INDEX_NAME) > AnArray(Index + 1, INDEX_NAME) Then
                Temp(1) = AnArray(Index + 1)
                AnArray(Index + 1) = AnArray(Index)
                AnArray(Index) = Temp(1)
                SwapCount = SwapCount + 1
            End If
        Next
    Loop
    End Sub
     
  3. erst mal thx !

    jetzt sieht schon besser aus jedoch wenn ich jetzt ne eingabe macht
    und bestädige

    sagt er index auserhalb des bereichs

    und springt dann zu der zeile ?

    [sub]
    ActiveWorkbook.Worksheets((Papier_Basis)).Copy Before:=Worksheets((Papier_Basis))[/sub]
     
  4. Das heißt zu deutsch:
    Es gibt in der Mappe kein Blatt mit dem Namen
    Code:
    (Papier_Basis)
    (mit Klammern ).
    Das wird aber erwartet  ;)

    Gruß Matjes :)
     
Die Seite wird geladen...