Microsoft Excel

Herbers Excel/VBA-Archiv

Änderung VBA Code

Betrifft: Änderung VBA Code von: Bernd
Geschrieben am: 17.08.2014 06:53:24

Wunderschönen guten morgen liebe Excelgemeinde!

Mir wurde hier bereits super geholfen durch Sergej, Oberschlumpf und vielen anderen. Nochmals Tausend Dank dafür. Deshalb ist auch der VBA Code in meiner Beispieldatei von hier.

Bin damit sehr sehr glücklich, hätte da aber dennoch einen kleinen Wunsch bzw. Bitte, ob mir jemand weiter helfen könnte.

Habe alle Tips und Codes in meine Exceldatei eigearbeitet und dachte mir, ob es denn nicht möglich sei, aufgrund dieses Codes so eine Art Seitenanzahl, die sich jedoch leider ändern kann, einzubauen.

Meine VBA Kentnisse reichen dafür leider nicht aus bzw. weiß ich gar nicht, ob es denn überhaupt machbar ist?

Hier mal meine Beispieldatei mit einer exakten Beschreibung meines Anliegens:

https://www.herber.de/bbs/user/92153.xlsm

Hoffe ich habe mich Verständlich ausgedrückt, wünsche noch einen schönen Sonntag und verbleibe mit freundlichen Grüßen,

Bernd

  

Betrifft: AW: Änderung VBA Code von: Crazy Tom
Geschrieben am: 17.08.2014 07:35:20

Hallo Bernd

sieht zwar nicht ganz sauber aus, erfüllt aber seinen Zweck

    Dim i As Integer
    For i = 1 To Worksheets.Count
        Cells(i + 2, 2) = Sheets(i).Name
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 2, 2), Address:="", SubAddress:= _
        "'" & Sheets(i).Name & "'!A1", TextToDisplay:=Sheets(i).Name
        ActiveWorkbook.Sheets(i).Cells(2, 2).Value = Sheets(i).Index - 1
        Sheets("01. Übersichtsliste").Range("A3").Clear
        Sheets("01. Übersichtsliste").Range("B2").Clear
        Cells(i + 2, 1) = Sheets(i).Cells(2, 2).Value
    Next 'i

MfG Tom


  

Betrifft: AW: Änderung VBA Code von: Bernd
Geschrieben am: 17.08.2014 08:41:50

Hallo Tom!

Danke funktioniert Ausgezeichnet.

Hab leider vorhin vergessen auf meinen 4. Punkt.

Ich würde nun gerne, die automatisch generierte Zahl als Seitennummer
unten Rechts (Fußzeile) einfügen.

Wie muss ich das anstellen?

lg und Danke für Deine Mühen,

Bernd


  

Betrifft: noch ein Vorschlag von: Erich G.
Geschrieben am: 17.08.2014 09:01:38

Hi Bernd,
noch ein Codevorschlag (noch ohne 4.):

Option Explicit                        ' IMMER zu empfehlen

Sub sbName()
   Dim strN As String
   Dim X As Integer
   Dim Y As Integer
   Dim i As Integer

'  Application.ScreenUpdating = False     ' evtl. NACH dem Test aktivieren
   With Sheets("01. Übersichtsliste")
      .Unprotect
      For X = 1 To Worksheets.Count - 1
         For Y = X + 1 To Worksheets.Count
            If Worksheets(Y).Name < Worksheets(X).Name Then
               Worksheets(Y).Move Before:=Worksheets(X)
            End If
         Next Y
      Next X
      .Activate
   
      Range("A:B").ClearContents
      For i = 1 To Worksheets.Count
         strN = Worksheets(i).Name
         .Cells(i + 2, 2) = strN
         .Hyperlinks.Add Anchor:=Cells(i + 2, 2), Address:="", _
            SubAddress:="'" & strN & "'!A1", TextToDisplay:=strN
         If .Name <> strN Then
            Worksheets(i).Cells(2, 2).Value = i - 1
            .Cells(i + 2, 1) = i - 1
         End If
      Next i
   
      With .Columns("A:A").Font
         .Name = "Arial"
         .Size = 12
         .Strikethrough = False
         .Superscript = False
         .Subscript = False
         .OutlineFont = False
         .Shadow = False
      End With
      .Columns("A:A").EntireColumn.AutoFit
      Application.GoTo Reference:="R3C1"
      .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   End With
   Application.ScreenUpdating = True
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: noch ein Vorschlag von: Bernd
Geschrieben am: 17.08.2014 09:08:54

Hallo Erich!

Danke Dir für Deinen Vorschlag. Da ja mein VBA Wissen nur begrenzt ist, muss ich sagen, es funktioniert auch Deine Lösung bestens.

Um aber keinen von Euch beiden zu Beleidigen, verrate ich nicht, welche Version ich nun Verwende :-)

Trotzdem vielen lieben Dank vorerst, und hoffe, auch für meinen 4. Wunsch gibt es eine Lösung.

lg Bernd


  

Betrifft: und zu 4. von: Erich G.
Geschrieben am: 19.08.2014 09:02:38

Hi Bernd,
... gibt es auch eine Lösung:

Option Explicit                        ' IMMER zu empfehlen

Sub sbName()
   Dim strN As String, X As Long, Y As Long, i As Long

'  Application.ScreenUpdating = False     ' evtl. NACH dem Test aktivieren
   With Sheets("01. Übersichtsliste")
      .Unprotect
      For X = 1 To Worksheets.Count - 1
         For Y = X + 1 To Worksheets.Count
            If Worksheets(Y).Name < Worksheets(X).Name Then
               Worksheets(Y).Move Before:=Worksheets(X)
            End If
         Next Y
      Next X
      .Activate
   
      Range("A:B").ClearContents
      Application.PrintCommunication = False
      For i = 1 To Worksheets.Count
         strN = Worksheets(i).Name
         .Cells(i + 2, 2) = strN
         .Hyperlinks.Add Anchor:=Cells(i + 2, 2), Address:="", _
            SubAddress:="'" & strN & "'!A1", TextToDisplay:=strN
         If .Name <> strN Then
            .Cells(i + 2, 1) = i - 1
            Worksheets(i).Cells(2, 2).Value = i - 1
            Worksheets(i).PageSetup.RightFooter = CStr(i - 1)
         End If
      Next i
      .Columns("A:A").EntireColumn.AutoFit
      Application.PrintCommunication = True
      Application.GoTo Reference:="R3C1"
      .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   End With
   Application.ScreenUpdating = True
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: und zu 4. --> Bingo von: Bernd
Geschrieben am: 19.08.2014 19:48:06

Hallo Erich !

Ich Danke Dir von ganzem Herzen, der Wahnsinn, wie Du mir geholfen hast.

Hab ja nicht mehr an eine Lösung gedacht. Denn während des Wartens habe ich Stunden damit verbracht,
zigtausend Vorschläge anderer zu Testen, natürlich ohne Erfolg.

Aber jetzt funzt es ja so wie ich es wollte.

Nochmals recht herzlichen Dank, viele liebe Grüße, aus dem verregneten Klagenfurt am Wörthersee, nach Kamp-Lintfort, an Dich und Deinen nächsten.

lg Bernd


  

Betrifft: AW: Änderung VBA Code von: Adis
Geschrieben am: 17.08.2014 20:55:35

Hallo

vieles ist machbar , probier es einfach aus. Lege ein zweites Modulblatt als Kopie an (zur Vorsicht)
und kopiere das geäenderte Makro ins Modublatt1. Ich habe es getestet, müsste funktionieren.

Die Änderung wurde von mir mit Kommentar dokumentiert, damit man verstehen kann was passiert.
Einige Programmteile sind überflüssig, dann habe ich es mit Kommentar versehen. Viel Spass beim Test.

Sub sbName() 'geäendert von Adis  17.8.2014 für Herber Forum
    ActiveSheet.Unprotect
Application.ScreenUpdating = False
Dim WS As Worksheet
    Dim X As Integer
    Dim Y As Integer
    Set WS = ActiveSheet
    For X = 1 To ActiveWorkbook.Worksheets.Count
        For Y = X To ActiveWorkbook.Worksheets.Count
            If Worksheets(Y).Name < Worksheets(X).Name Then
                Worksheets(Y).Move Before:=Worksheets(X)
            End If
        Next Y
    Next X
    WS.Activate
    Set WS = Nothing
Dim i As Integer
For i = 1 To Worksheets.Count
   'neu eingefügt von Adis  17.8.2014
   'Zahl in B2 und Name in A1 auf laufende Nummer aendern
   If i > 1 Then  '1. Blatt Übersichtliste nicht ausfüllen
      Sheets(i).Cells(2, 2) = i - 1    'Zelle B2 aendern
      Sheets(i).Cells(1, 1) = Sheets(i).Name & " " & i - 1
   End If
   'Cells(1+2, 1-2)  1 und 2 nur umgetauscht
   Cells(i + 2, 2) = Sheets(i).Name
   Cells(i + 2, 1) = Sheets(i).Cells(2, 2).Value
   ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 2, 2), Address:="", SubAddress:= _
      "'" & Sheets(i).Name & "'!A1", TextToDisplay:=Sheets(i).Name
Next 'i
    'kann entfallen (oder gekürzt werden) weil Spalte B bereits formatiert ist
    '(ist nur sinnvoll als Makro Recorder Aufzeichnung) beim 1. Installieren!)
    Columns("B:B").Select
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False   'ab hier kann alles entfallen
        .Superscript = False     '(Makro Recorder Aufzeichnung)
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With
    'auf Spalte B geaendert
    Columns("B:B").EntireColumn.AutoFit
Application.ScreenUpdating = True
    Application.GoTo Reference:="R3C1"
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 End Sub
Sub Löschen()
' Löschen Makro
    ActiveSheet.Unprotect
    Range("A2:G272").ClearContents   '(ohne Selection...)
    Range("A4").Select  'auf A4 gesetzt statt C4
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Gruss Adis


  

Betrifft: AW: Änderung VBA Code von: Bernd
Geschrieben am: 18.08.2014 04:18:45

Hallo Adis!

Erstmal sage ich Danke für Deine Hilfe. Leider ist es so, wenn ich Deinen Code verwende, spielen sich seltsame Dinge ab.

Meine Musterdatei ist nur ähnlich aufgebaut, die Originale hat auch zB.: einen Makro VBA Code wo ich ein Tabellenblat kopiere, dieses wird nun automatisch umgeschrieben.

In der Verbundenen Zelle A1 wird mein Name um eine Nummer erweitert, zB.: von Muster auf Muster1, Test auf Test2 usw.

Und, wenn ich auf Druckansicht gehe, ist keine Seitennummer, als Fußzeile rechts, vorhanden.


Der Code von den beiden Ersthelfern funktioniert einwandfrei, es fehlt nur noch, dass eben die Seitennummer mit ausgedruckt wird.

Trotzdem nochmlas Danke für Deine Hilfe.

lg Bernd


 

Beiträge aus den Excel-Beispielen zum Thema "Änderung VBA Code"