Makros unter Excel

Diese Seite verwendet Cookies. Durch die Nutzung unserer Seite erklären Sie sich damit einverstanden, dass wir Cookies setzen. Weitere Informationen

  • Makros unter Excel

    Hat / Oder haben hier welche tiefer gehende Kenntnisse von Makros in Excel?
    Ich bastele hier schon seit einiger Zeit an einem Makro der mich noch um die Ecke bringt.
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Shell-Script

    1. Dim SavedBook As String
    2. Const MaxBooks = 5
    3. 'Maximal 5 Sicherungen von http://www.ms-office-forum.net/forum/showthread.php?t=271536
    4. Dim I As Integer
    5. Dim BackupPfad As String
    6. Dim KillBook As String
    7. '
    8. Application.ScreenUpdating = False
    9. Application.DisplayAlerts = False
    10. BackupPfad = Environ("Userprofile") & "\Desktop\"
    11. 'etwas hinter Desktop schreiben ändert nur den Namen der Datei"
    12. 'ThisWorkbook.Path`= speicher einen höher und löscht nicht die > 5 Stck raus,
    13. 'ThisWorkbook.Name = speicher im selben Ordner, und löscht nicht die > 5 Stck raus,
    14. 'ThisWorkbook.FullName = läuft auf Laufzeitfehler 53 auf.
    15. SavedBook = BackupPfad & "Backup - *"
    16. 'Pfad der Backups festlegen
    17. KillBook = "Backup - 99999999999999.xlsm"
    18. 'KillBook mit neuest möglichem Datum versehen
    19. I = 0
    20. SavedBook = Dir(SavedBook)
    21. 'Erstes Backup suchen
    22. While SavedBook <> "" And I < MaxBooks
    23. 'Gibt es Backups? Und sind es auch 5?
    24. If KillBook > SavedBook Then
    25. 'ist Killbook neuer als das Backup?
    26. KillBook = SavedBook
    27. 'Killbook wird mit dem älteren backup belegt
    28. End If
    29. I = I + 1
    30. SavedBook = Dir
    31. 'Nächstes Backup suchen
    32. Wend
    33. If I = MaxBooks Then
    34. 'Wenn es schon 5 Backups gibt, wird das älteste gelöscht
    35. Kill BackupPfad & KillBook
    36. End If
    37. With ActiveWorkbook
    38. .SaveCopyAs BackupPfad & "Backup - " & _
    39. Format(Now(), "yyyymmddhhnnss") & ".xlsm"
    40. ' mit "yyyymmddhhnnss" ist es einfacher die älteste Mappe zu finden
    41. 'als mit "DD.MM.YY HH.MM" und Sekunden sind jetzt auch dabei
    42. 'Und die Minuten sind ^^ NN, nicht MM
    43. '.Close
    44. 'Warum Close...
    45. End With
    46. 'Workbooks.Open oldBook
    47. '...und wieder Open? Bei Close würde die VB Ausführung stoppen.
    48. Application.DisplayAlerts = True
    49. Application.ScreenUpdating = True
    Alles anzeigen



    ---------- 13. Juni 2017, 19:54 ----------

    Ich habe da ein Makro gefunden, der macht eigentlich genau das was ich möchte. Vor Ausführung des eigentlichen Makros speichert er die Datei. Davon bis zu 5 Stck, dann überschreibt dieser die alten. Läuft soweit gut. Leider speichert er dieser aber auf den Desktop ab. Ich versuche nun schon den ganzen Tag mir diesen anzupassen. Leider bekomme ich es nicht hin. Viel Ahnung habe ich leider sowieso nicht. Was möchte ich gerne? Ich hätte gerne, dass im selben Ordner, wie die Ursprungsdatei ein Ordner „Backup“ mit dem selben Namen wie die Ursprungsdatei gebildet wird und darunter die 5 Backups mit dem selben Namen wie die Ursprungsdatei + Backup + Datum-Uhrzeit-Sekunden gebildet werden. Die Exceldatei ist ein Basisdatei die immer als Blankette verwendet und dann unter anderen Namen abgespeichert wir. Daher muss auch dieser Name sich an der Bezugsdatei anpassen.

    Datei XYZ
    Datei 123
    Backup Datei 123 / Backup Datei 123 – 20170612213915 (1 bis 5)
    Datei ABC
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Das bestimmt doch die Zeile backuppfad. Mit Application.ActiveWorkbook.Path bestimmst du den aktuellen Ordner deiner geöffneten Datei, mit Application.ActiveWorkbook.FullName den Pfad inkl Dateiname. Das haust du dir in nen Dim und kannst es danach benutzen.
    Schreib grad nur vom Handy, wenns bis morgen nicht klappt gibts mehr.
  • BackupPfad = Application.ThisWorkbook.Path & "\Backup\"

    Allerdings muss das Verzeichnis Backup dann existieren. Sonst gibt es einen Fehler. Also am besten anlegen wenn nicht vorhanden.


    ---------- 13. Juni 2017, 20:56 ----------

    Hier mal auf die schnelle:

    Quellcode

    1. Public Sub DoBackup()
    2. Dim SavedBook As String
    3. Const MaxBooks = 5
    4. Dim I As Integer
    5. Dim BackupPfad As String
    6. Dim KillBook As String
    7. Application.ScreenUpdating = False
    8. Application.DisplayAlerts = False
    9. DateiName = ThisWorkbook.Name
    10. If InStr(DateiName, ".") > 0 Then
    11. DateiName = Left(DateiName, InStr(DateiName, ".") - 1)
    12. End If
    13. BackupPfad = ThisWorkbook.Path & "\Backup " & DateiName
    14. If Dir(BackupPfad, vbDirectory) = "" Then
    15. MkDir (BackupPfad)
    16. End If
    17. BackupPfad = BackupPfad & "\"
    18. SavedBook = BackupPfad & "Backup " & DateiName & " - *"
    19. KillBook = "Backup " & DateiName & " - 99999999999999.xlsm"
    20. I = 0
    21. SavedBook = Dir(SavedBook)
    22. While SavedBook <> "" And I < MaxBooks
    23. If KillBook > SavedBook Then
    24. KillBook = SavedBook
    25. End If
    26. I = I + 1
    27. SavedBook = Dir
    28. Wend
    29. If I = MaxBooks Then
    30. Kill BackupPfad & KillBook
    31. End If
    32. With ActiveWorkbook
    33. .SaveCopyAs BackupPfad & "Backup " & DateiName & " - " & _
    34. Format(Now(), "yyyymmddhhnnss") & ".xlsm"
    35. End With
    36. Application.DisplayAlerts = True
    37. Application.ScreenUpdating = True
    38. End Sub
    Alles anzeigen
  • WOW

    SUPER

    Da treibe ich mich seit einer Wochen in den Excel Foren rum und wo bekomme ich die Antwort.
    In das Makro bildet sogar ein eigenes Unterverzeichnis. Das löst alle Problem....

    DANKE

    Keine Bange. Kommen bestimmt noch ein paar Fragen :D


    ---------- 13. Juni 2017, 22:00 ----------

    Auch Dir meinen Dank dermarc.
    Du bekommst noch Deine Chance - sei dir sicher ;)


    ---------- 13. Juni 2017, 23:09 ----------

    Ich möchte Euch nicht enttäuschen!
    Einen habe ich (vorerst) nocht.

    Ich habe hier ein Codeschnipsel

    Quellcode

    1. With Selection.Interior
    2. .Pattern = xlSolid
    3. .PatternColorIndex = xlAutomatic
    4. .ThemeColor = xlThemeColorDark1
    5. .TintAndShade = -4.99893185216834E-02
    6. .PatternTintAndShade = 0
    7. End With
    8. Selection.Font.Bold = True 'ab hier Zelle markieren und Sternchen einfügen
    9. ActiveCell.Offset(0, 3).Range("A1").Select
    10. ActiveCell.FormulaR1C1 = "*"
    11. ActiveCell.Offset(2, 4).Range("A1").Select
    Alles anzeigen
    Das ist das Ende eines Codes das Rechenoperanden quer durch die Excel Tabelle verteil.
    Dann färbt der Code die Zeile grau und gibt an das die Schrift in der Zeile fett werden soll.
    Dann springt der Code in die betreffende Zelle der Spalte "D" und setzt ein Sternchen (für späteres Autofiltern, dann springt der Code in seine Soll-Position 4 nach rechts und 2 runter.

    Ich hätte noch gerne, dass er nach den Sternchen setzen, noch in den 2 rechts daneben befindlichen aber schon beschrifteten Zellen noch das Wörtchen "Summe (Leerzeichen)" davor schreibt und dann hiernach 2 nach rechts und 2 runter.

    Ich habe da schon was gebastelt. Dooferweise ende ich immer überall nur nicht genau da wo ich hin will.:-(

    Nicht das Ihr Euch ausgenutzt fühlt, aber ich kann einfach nicht widerstehen..........
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Carden Mark schrieb:


    Ich hätte noch gerne, dass er nach den Sternchen setzen, noch in den 2 rechts daneben befindlichen aber schon beschrifteten Zellen noch das Wörtchen "Summe (Leerzeichen)" davor schreibt und dann hiernach 2 nach rechts und 2 runter.
    Auf die Schnelle, meinst Du in etwa so?
    Wobei i,5 und i,6 einen String bilden, soll das wirklich so sein?

    #################################################
    Sub test()
    Dim i&
    i = ActiveCell.Row
    Cells(i, 4).FormulaR1C1 = "*" 'Sternchen in Spalte D
    Cells(i, 5).Value = "Summe: " & Cells(i, 5).Value 'Spalte E
    Cells(i, 6).Value = "Summe: " & Cells(i, 6).Value 'Spalte F
    Cells(i + 2, 8).Select 'zwei runter, zwei nach rechts
    End Sub
    #################################################
    ---
    It's not the hammer, it is the way you hit.
  • Hi Trekki
    Super - macht genau was ich wollte. Danke
    String ?? verstehe ich so, da ich da Text drin habe - ist das was Du meinst?
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Ja genau das meinte ich, weiss ja nicht, ob du mit cells i,5 und i,6 später mal noch rechnen möchtest/musst.
    Achja und falls das Makro mehrfach läuft und da schon 'Summe: ' drinnen steht, dann tausch die zwei Zeilen gegen diese:

    If Not Split(Cells(i, 5))(0) = "Summe:" Then Cells(i, 5).Value = "Summe: " & Cells(i, 5).Value
    If Not Split(Cells(i, 6))(0) = "Summe:" Then Cells(i, 6).Value = "Summe: " & Cells(i, 6).Value

    ... sonst steht da dann Summe: Summe: Summe: 123 ;)
    ---
    It's not the hammer, it is the way you hit.
  • Super - dass hatte mich beim rumprobieren schon ganz verrückt gemacht.
    Einen Fehler habe ich aber nun irgendwie nach dem ich alle Makros in einzelnen Mappen probiert hatte und nun zusammengefügt habe.

    Planmäßig soll das strg. "s" Makro unter anderen die Schrift fett machen.
    Jetzt geht das nicht mehr.
    Ich habe das Makro mehrfach kopiert.
    Es macht die Schrift in der Bezugsspalte einfach nicht fett.
    Das selbe Makro in einer eigenen Mappe schon.
    Wie kommt das?

    Quellcode

    1. Sub Titelsummen()
    2. '
    3. ' Titelsummen bilden, kopieren, Spalte eingrauen+Dickschrift,Sternchen
    4. Dim SavedBook As String ' ab hier: vorgeschaltete Sicherheitskopeierstellung, falls ein Makro versehentlich aktiviert wird.
    5. Const MaxBooks = 5
    6. Dim I As Integer
    7. Dim BackupPfad As String
    8. Dim KillBook As String
    9. Application.ScreenUpdating = False
    10. Application.DisplayAlerts = False
    11. DateiName = ThisWorkbook.Name
    12. If InStr(DateiName, ".") > 0 Then
    13. DateiName = Left(DateiName, InStr(DateiName, ".") - 1)
    14. End If
    15. BackupPfad = ThisWorkbook.Path & "\Backup " & DateiName
    16. If Dir(BackupPfad, vbDirectory) = "" Then
    17. MkDir (BackupPfad)
    18. End If
    19. BackupPfad = BackupPfad & "\"
    20. SavedBook = BackupPfad & "Backup " & DateiName & " - *"
    21. KillBook = "Backup " & DateiName & " - 99999999999999.xlsm"
    22. I = 0
    23. SavedBook = Dir(SavedBook)
    24. While SavedBook <> "" And I < MaxBooks
    25. If KillBook > SavedBook Then
    26. KillBook = SavedBook
    27. End If
    28. I = I + 1
    29. SavedBook = Dir
    30. Wend
    31. If I = MaxBooks Then
    32. Kill BackupPfad & KillBook
    33. End If
    34. With ActiveWorkbook
    35. .SaveCopyAs BackupPfad & "Backup " & DateiName & " - " & _
    36. Format(Now(), "yyyymmddhhnnss") & ".xlsm"
    37. End With
    38. Application.DisplayAlerts = True
    39. Application.ScreenUpdating = True
    40. ' Tastenkombination: Strg+s
    41. '
    42. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    43. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    44. ActiveCell.Offset(0, 1).Range("A1").Select
    45. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    46. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    47. ActiveCell.Offset(0, 8).Range("A1").Select
    48. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    49. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    50. ActiveCell.Offset(0, 1).Range("A1").Select
    51. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    52. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    53. ActiveCell.Offset(0, 1).Range("A1").Select
    54. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    55. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    56. ActiveCell.Offset(0, 1).Range("A1").Select
    57. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    58. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    59. ActiveCell.Offset(0, 1).Range("A1").Select
    60. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    61. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    62. ActiveCell.Offset(0, 1).Range("A1").Select
    63. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    64. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    65. ActiveCell.Offset(0, 1).Range("A1").Select
    66. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    67. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    68. ActiveCell.Offset(0, 1).Range("A1").Select
    69. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    70. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    71. ActiveCell.Offset(0, 1).Range("A1").Select
    72. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    73. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    74. ActiveCell.Rows("1:1").EntireRow.Select 'ab hier Zeile, markieren, grau, dicke Schrift
    75. With Selection.Interior
    76. .Pattern = xlSolid
    77. .PatternColorIndex = xlAutomatic
    78. .ThemeColor = xlThemeColorDark1
    79. .TintAndShade = -4.99893185216834E-02
    80. .PatternTintAndShade = 0
    81. End With
    82. I = ActiveCell.Row
    83. Cells(I, 4).FormulaR1C1 = "*" 'Sternchen in Spalte D
    84. If Not Split(Cells(I, 5))(0) = "Summe:" Then Cells(I, 5).Value = "Summe: " & Cells(I, 5).Value 'Spalte E ist die fünfte Spalte von links
    85. If Not Split(Cells(I, 6))(0) = "Summe:" Then Cells(I, 6).Value = "Summe: " & Cells(I, 6).Value 'Spalte Fist die sechste Spalte von links
    86. Cells(I + 1, 4).Select 'ein runter, null nach rechts
    87. Cells(I + 1, 4).FormulaR1C1 = "." 'ein runter, null nach rechts, einfügen "." damit der Autofilter nicht in der ersten Leerzelle hängen bleibt
    88. Cells(I + 2, 4).FormulaR1C1 = "." 'wie vor
    89. Cells(I + 2, 8).Select 'null runter, zwei nach rechts
    90. End Sub
    Alles anzeigen
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Carden Mark schrieb:



    Planmäßig soll das strg. "s" Makro unter anderen die Schrift fett machen.
    Jetzt geht das nicht mehr.
    Ich habe das Makro mehrfach kopiert.
    Es macht die Schrift in der Bezugsspalte einfach nicht fett.
    Das selbe Makro in einer eigenen Mappe schon.
    Wie kommt das?
    Möglicherweise irgendwas mit ThisWorkbook, ActiveWorkbook oder den entsprechenden Sheets.
    In Zeile 85 benimst du eine ganze Zeile (Spalte find ich nix?), allerdings immer über den Bezug Activecell, ohne Blatt oder Dateiname voran.

    Wenn Du mal eine kleine, sinngemäße Beispieltabelle hättest, was wo wie soll, wäre es einfacher als mit dem Recorderquarki, weil man nicht weiss, wo Activecell startet bzw. die selection liegt ;)


    ---------- 14. Juni 2017, 19:48 ----------

    Ich hatte mal deinen Code laufen lassen und gekuckt was passiert ab dem Part strg+s,
    wäre dies in etwa das, wo du hin möchtest (Autosumme aller belegter Zellen von A1 bis Spalte R1) ?

    Quellcode

    1. Sub mark() Dim r As Long, c As Integer r = Cells(Rows.Count, 1).End(xlUp).Row 'Debug.Print r 'r=Zeilenzähler With Worksheets("Tabelle1") For c = 1 To 19 'Spaltenschleife .Cells(r + 2, c).Formula = WorksheetFunction.Sum(.Range(.Cells(1, c), .Cells(r, c))) Next .Range(.Cells(r + 2, 1), .Cells(r + 2, 19)).Font.Bold = True .Cells(r + 2, 3) = "" .Cells(r + 2, 4) = "*" .Cells(r + 2, 7) = "" If Not Split(.Cells(r + 2, 5))(0) = "Summe:" Then .Cells(r + 2, 5).Value = "Summe: " & .Cells(r + 2, 5).Value If Not Split(.Cells(r + 2, 6))(0) = "Summe:" Then .Cells(r + 2, 6).Value = "Summe: " & .Cells(r + 2, 6).Value End WithEnd Sub
    ??????????

    nochmal ohne Formatierung


    #######################################################################################

    Sub mark()
    Dim r As Long, c As Integer
    r = Cells(Rows.Count, 1).End(xlUp).Row
    'Debug.Print r 'r=Zeilenzähler
    With Worksheets("Tabelle1")
    For c = 1 To 19 'Spaltenschleife
    .Cells(r + 2, c).Formula = WorksheetFunction.Sum(.Range(.Cells(1, c), .Cells(r, c)))
    Next
    .Range(.Cells(r + 2, 1), .Cells(r + 2, 19)).Font.Bold = True
    .Cells(r + 2, 3) = ""
    .Cells(r + 2, 4) = "*"
    .Cells(r + 2, 7) = ""
    If Not Split(.Cells(r + 2, 5))(0) = "Summe:" Then .Cells(r + 2, 5).Value = "Summe: " & .Cells(r + 2, 5).Value
    If Not Split(.Cells(r + 2, 6))(0) = "Summe:" Then .Cells(r + 2, 6).Value = "Summe: " & .Cells(r + 2, 6).Value
    End With
    End Sub
    ########################################################################################
    ---
    It's not the hammer, it is the way you hit.
  • hmmm
    Ich habe Dein Makro mal übernommen und erhalte nur Laufzeitfehler 9.
    Daher weiß ich nicht was es macht.
    Ich überlege mir mal wie ich hier die Tabelle rein kriege.
    Am liebsten wurde ich die Exceldatei reinkopieren :)


    ---------- 14. Juni 2017, 20:49 ----------

    Ich hoffe das hilft weiter.
    Excel bekomme ich leider nicht hochgeladen :)
    Die grauen Querstreifen (Zeilen) werden nicht fett geschrieben nachdem die Makros nun alle in einer Datei sind.
    Dateien
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • In welcher Zeile?

    Nochmal mit r im with-Bereich und font.bold auskommentiert, da ich xl2000 habe ;)

    Sub mark()
    Dim r As Long, c As Integer

    With Worksheets("Tabelle1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row ': Debug.Print r ' letzte belegte Zeile
    For c = 1 To 19 'Spaltenschleife
    .Cells(r + 2, c).Formula = WorksheetFunction.Sum(.Range(.Cells(1, c), .Cells(r, c)))
    Next
    '.Range(.Cells(r + 2, 1), .Cells(r + 2, 19)).Font.Bold = True
    .Cells(r + 2, 3) = ""
    .Cells(r + 2, 4) = "*"
    .Cells(r + 2, 7) = ""
    If Not Split(.Cells(r + 2, 5))(0) = "Summe:" Then .Cells(r + 2, 5).Value = "Summe: " & .Cells(r + 2, 5).Value
    If Not Split(.Cells(r + 2, 6))(0) = "Summe:" Then .Cells(r + 2, 6).Value = "Summe: " & .Cells(r + 2, 6).Value
    End With
    End Sub
    ---
    It's not the hammer, it is the way you hit.
  • In welcher Zeile?
    Laufzeutfehler 9 - immer noch und wenn ich debugge ist folgendes gelb
    With Worksheets("Tabelle1")
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • wie heisst denn deine tabelle?
    Es muss lauten: with worksheets("DeinTabellenname"),

    wobei:

    da ich nur xl2k habe und nicht weiss wie die aktuellen Versionen sind, kanns auch ein Versionsfehler sein?


    ---------- 14. Juni 2017, 21:37 ----------

    Nochwas, hab mal deine pdf angeschaut, du möchtest immer ab activecell (deine Cursorposition) die einzelnen Losbereichssummen 01 bis 0x aufsummieren?
    Wenn du mit der Krücke (activecell manuell setzen) leben kannst, probier ichs mal, die ganze Tabelle auf einen Hieb automatisch trau' ich mir nicht zu, ginge sicher mit arrays,
    aber hab >10 jahre nix mit vba gemacht.
    ---
    It's not the hammer, it is the way you hit.
  • hmmmm
    sind
    das

    Quellcode

    1. r = .Cells(Rows.Count, 1).End(xlUp).Row ': Debug.Print r ' letzte belegte Zeile


    und das


    Quellcode

    1. '.Range(.Cells(r + 2, 1), .Cells(r + 2, 19)).Font.Bold = True
    sind das wirklich Hochkomma?
    Die werden doch für Erläuterungen eingefügt und der Text danach ist kein Teil des Makros - oder?


    ---------- 14. Juni 2017, 21:46 ----------

    Ach Ja
    Das Tabellenblatt heißt LV
    So hatte ich das geändert

    Quellcode

    1. With Worksheets("LV")
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Ja das sind hochkommata, damit kann Code auskommentiert werden, also quasi ausgeschaltet oder eben für 'echte' Erläuterungen/Kommentare benutzt werden,
    die erste Zeile, nach end(xlup).row --- das 'debug.print und 'letzte belegte zeile das ist quasi entschärft (kannste auch löschen)

    die Zeile mit font.bold=true hatte ich auskommentiert wg. evtl. Versionsunterschiede zur Fettschrift zw. meinem Excel (2000) und deinem (aktuelleren) Excel
    ---
    It's not the hammer, it is the way you hit.
  • Quellcode

    1. Sub mark()
    2. Dim r As Long, c As Integer
    3. With Worksheets("LV")
    4. r = .Cells(Rows.Count, 1).End(xlUp).Row ': Debug.Print r ' letzte belegte Zeile
    5. For c = 1 To 19 'Spaltenschleife
    6. .Cells(r + 2, c).Formula = WorksheetFunction.Sum(.Range(.Cells(1, c), .Cells(r, c)))
    7. Next
    8. '.Range(.Cells(r + 2, 1), .Cells(r + 2, 19)).Font.Bold = True
    9. .Cells(r + 2, 3) = ""
    10. .Cells(r + 2, 4) = "*"
    11. .Cells(r + 2, 7) = ""
    12. If Not Split(.Cells(r + 2, 5))(0) = "Summe:" Then .Cells(r + 2, 5).Value = "Summe: " & .Cells(r + 2, 5).Value
    13. If Not Split(.Cells(r + 2, 6))(0) = "Summe:" Then .Cells(r + 2, 6).Value = "Summe: " & .Cells(r + 2, 6).Value
    14. End With
    15. End Sub
    Alles anzeigen

    was soll ich sagen?
    Ich weiß nicht was der Code machen soll, aber er läuft nicht bei mir.
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Mal folgender Test, probiere mal das Codesnippet:

    ###################
    Sub asdf()
    Dim r As Long
    With Worksheets(" LV ")
    r = .Cells(Rows.Count, 2).End(xlUp).Row 'letzte belegte Zeilennummer in Spalte 2
    Debug.Print r ' Ausgabe Wert der Variablen r im Direktfenster
    Debug.Print .Cells(r, 2).Font.Bold 'Prüfen ob Fettschrift in Zeile r, Spalte 2 im Direktfenster
    End With
    End Sub
    ####################

    ... ergibt bei meiner Testmappe im Direktfenster folgende Ausgabe:

    #######
    13 ' letzte Zeilennummer in Spalte 2 (B)
    Falsch ' --> keine Fettschrift in B13, Ausgabe wäre Wahr wenn B13 Fett
    #######

    oder mal ganz ohne alles, einfach mal die jeweilige Zeile mit ? eingeben im Direktfenster und abentern:

    #######################
    ?worksheets(" LV ").Cells(Rows.Count, 2).End(xlUp).Row '& Enter
    13
    ?now '& Enter
    14.06.2017 23:55:39
    ?split("test eins zwei")(0) '& Enter
    test
    ?split("test eins zwei")(1) 'usw
    eins
    ?split("test eins zwei")(2)
    zwei
    #######################

    Am besten man gewöhnt sich an Direktfenster und Lokalfenster, da kann man vieles abprüfen,
    blende dir das unter 'Ansicht' ein, hilft viel zum Verständnis und bei der Fehlersuche.

    Eigentlich wäre noch viel zu fragen/sagen, aber ich muss erstmal in die Falle.
    Nur soviel, halbwegs die Grundlagen müssen verstanden sein, dann machts auch Spaß, selbst weiterzuentwickeln,
    sofern Zeit & Nerven vorhanden ;)
    ---
    It's not the hammer, it is the way you hit.
  • Ich versuche gleich Mal zu ergründen was Du mir versucht hast mitzuteilen :)

    Wenn ich es richtig sehe, fängt in diesen Teilschnipsel doch mein Problem an:

    Quellcode

    1. ActiveCell.Rows("1:1").EntireRow.Select 'ab hier Zeile, markieren, grau, dicke Schrift
    2. With Selection.Interior 'ist das Problem evtl. das "Selektion", wird im I-Net vor gewarnt
    3. .Pattern = xlSolid
    4. .PatternColorIndex = xlAutomatic
    5. .ThemeColor = xlThemeColorDark1
    6. .TintAndShade = -4.99893185216834E-02
    7. .PatternTintAndShade = 0
    8. End With
    Da drüber und da drunter läuft alles.
    Im I-Net lese ich immer wieder dass "Selektion" ein Problem sein kann.
    Kann das sein?
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Versuch mal das Snippet ohne Selection bzw. wenn wieder Fehlermeldung was sagt diese?

    Achja, kopiere sub x() mal in ein Modul, parke deinen Cursor irgendwo zwischen sub x() und end sub
    und drücke F8, damit kannst Du im Einzelschritt Zeile für Zeile durchgehen und siehst wo er ggf. aussteigen will.
    Einzelschritt-Modus beenden mit Menü Ausführen > Zurücksetzen oder ganz normal immer weiter F8 bis end sub erreicht ist.

    Sub x()
    With ActiveCell.EntireRow.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    '.ThemeColor = xlThemeColorDark1
    '.TintAndShade = -4.99893185216834E-02
    '.PatternTintAndShade = 0
    End With
    End Sub
    ---
    It's not the hammer, it is the way you hit.
  • F8 ist sone Sache.
    Dann geht bei mir ein Popup auf damit ich telefonieren kann :(

    Aber ich habe rausbekommen warum die Schrift mal fett, mal nicht fett wurde.
    Der Grund ist aber zu peinlich.
    Offenbar waren die Zeilen schon auf fett voreingestellt.
    Jetzt versuche ich mal Deinen Code nochmal.


    ---------- 15. Juni 2017, 14:48 ----------

    Ich habe die beiden nebeneinander ausgetauscht.
    Passiert nichts.

    Quellcode

    1. With ActiveCell.EntireRow.Interior 'zu Testzwecke eingefügt
    2. ' With Selection.Interior

    Echt ärgerlich.
    Das Ding funzt jetzt über mehrere Tabellenblätter und verschiedenste WENN..blablabla. SVERWEISE, VVERWEISE.
    Nur in einem Tabellenblatt werden die Titelsummen nicht fett - mist.


    ---------- 15. Juni 2017, 14:56 ----------

    So, ich habe jetzt ein aufgenommenes Makro einfach reinkopiert. 96-98
    Jetzt läuft es offenbar.
    Blitzt und blinkt leider.
    Scheinbar alles nicht optimal.

    Quellcode

    1. Sub Titelsummen()
    2. '
    3. ' Titelsummen bilden, kopieren, Spalte eingrauen+Dickschrift,Sternchen
    4. Dim SavedBook As String ' ab hier: vorgeschaltete Sicherheitskopeierstellung, falls ein Makro versehentlich aktiviert wird.
    5. Const MaxBooks = 5
    6. Dim I As Integer
    7. Dim BackupPfad As String
    8. Dim KillBook As String
    9. Application.ScreenUpdating = False
    10. Application.DisplayAlerts = False
    11. DateiName = ThisWorkbook.Name
    12. If InStr(DateiName, ".") > 0 Then
    13. DateiName = Left(DateiName, InStr(DateiName, ".") - 1)
    14. End If
    15. BackupPfad = ThisWorkbook.Path & "\Backup " & DateiName
    16. If Dir(BackupPfad, vbDirectory) = "" Then
    17. MkDir (BackupPfad)
    18. End If
    19. BackupPfad = BackupPfad & "\"
    20. SavedBook = BackupPfad & "Backup " & DateiName & " - *"
    21. KillBook = "Backup " & DateiName & " - 99999999999999.xlsm"
    22. I = 0
    23. SavedBook = Dir(SavedBook)
    24. While SavedBook <> "" And I < MaxBooks
    25. If KillBook > SavedBook Then
    26. KillBook = SavedBook
    27. End If
    28. I = I + 1
    29. SavedBook = Dir
    30. Wend
    31. If I = MaxBooks Then
    32. Kill BackupPfad & KillBook
    33. End If
    34. With ActiveWorkbook
    35. .SaveCopyAs BackupPfad & "Backup " & DateiName & " - " & _
    36. Format(Now(), "yyyymmddhhnnss") & ".xlsm"
    37. End With
    38. Application.DisplayAlerts = True
    39. Application.ScreenUpdating = True
    40. ' Tastenkombination: Strg+s
    41. '
    42. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    43. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    44. ActiveCell.Offset(0, 1).Range("A1").Select
    45. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    46. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    47. ActiveCell.Offset(0, 8).Range("A1").Select
    48. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    49. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    50. ActiveCell.Offset(0, 1).Range("A1").Select
    51. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    52. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    53. ActiveCell.Offset(0, 1).Range("A1").Select
    54. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    55. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    56. ActiveCell.Offset(0, 1).Range("A1").Select
    57. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    58. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    59. ActiveCell.Offset(0, 1).Range("A1").Select
    60. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    61. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    62. ActiveCell.Offset(0, 1).Range("A1").Select
    63. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    64. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    65. ActiveCell.Offset(0, 1).Range("A1").Select
    66. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    67. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    68. ActiveCell.Offset(0, 1).Range("A1").Select
    69. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    70. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    71. ActiveCell.Offset(0, 1).Range("A1").Select
    72. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    73. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    74. ActiveCell.Rows("1:1").EntireRow.Select 'ab hier Zeile, markieren, grau, dicke Schrift
    75. ' With ActiveCell.EntireRow.Interior 'zu Testzwecke eingefügt
    76. With Selection.Interior
    77. .Pattern = xlSolid
    78. .PatternColorIndex = xlAutomatic
    79. .ThemeColor = xlThemeColorDark1
    80. .TintAndShade = -4.99893185216834E-02
    81. .PatternTintAndShade = 0
    82. End With
    83. I = ActiveCell.Row
    84. Cells(I, 4).FormulaR1C1 = "*" 'Sternchen in Spalte D
    85. ActiveCell.Rows("1:1").EntireRow.Select 'ab hier Zeile fett
    86. Selection.Font.Bold = True
    87. ActiveCell.Offset(0, 3).Range("A1").Select
    88. If Not Split(Cells(I, 5))(0) = "Summe:" Then Cells(I, 5).Value = "Summe: " & Cells(I, 5).Value 'Spalte E ist die fünfte Spalte von links
    89. If Not Split(Cells(I, 6))(0) = "Summe:" Then Cells(I, 6).Value = "Summe: " & Cells(I, 6).Value 'Spalte Fist die sechste Spalte von links
    90. Cells(I + 1, 4).Select 'ein runter, null nach rechts
    91. Cells(I + 1, 4).FormulaR1C1 = "." 'ein runter, null nach rechts, einfügen "." damit der Autofilter nicht in der ersten Leerzelle hängen bleibt
    92. Cells(I + 2, 4).FormulaR1C1 = "." 'wie vor
    93. Cells(I + 2, 8).Select 'null runter, zwei nach rechts
    94. End Sub
    Alles anzeigen


    Geht der folgende code (1-3) zufällig nur bis zur Spalte Z??
    Ich habe 6-8 versucht zuzufügen, der landet aber immer in Spalte Z anstelle in AB.




    Quellcode

    1. ActiveCell.Offset(0, 1).Range("A1").Select
    2. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-1, 0).End(xlUp), ActiveCell.Offset(-1, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    3. ActiveCell.Offset(1, 0).Resize(2).ClearContents
    4. ActiveCell.Offset(0, 1).Range("A1").Select
    5. ActiveCell.Formula = "=SUM(" & Range(ActiveCell.Offset(-3, 0).End(xlUp), ActiveCell.Offset(-3, 0)).Address & ")" 'dieser Teil gilt nur für die gemarkerte Zelle
    6. ActiveCell.Offset(1, 0).Resize(2).ClearContents

    Ich habe:


    ---------- 15. Juni 2017, 23:55 ----------

    Juhuuu
    Ich habe das Dinf (fast) so wie ich es haben will.
    Jetzt noch morgen ein paar Tricks überlegen wie Zeilen die wo keine Auswertbaren Passagen drin sind ausgeblendet werden und dann ist es geschafft.
    Das ganze soll eine Kalkulationssoftware werden mit Verknüpfung zu unserem Kypernetischen Nachkalkulationssystem.
    Das konnte bisher keiner liefern.


    Ich danke Euch noch einmal für Eure Unterstützung.
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk
  • Carden Mark schrieb:

    [...]

    Jetzt noch morgen ein paar Tricks überlegen wie Zeilen die wo keine Auswertbaren Passagen drin sind ausgeblendet werden und dann ist es geschafft.
    Das kannst Du z.B. mit einer Excelfunktion "WENN" bewerkstelligen

    =WENN(UND($F178>0,05;$F178<0,100001);1;"")

    Hier im Beispiel wird der Zellinhalt F178 auf seine Größe geprüft. In der Zelle, in der die Formel steht, erscheint eine 1 wenn der Wert in F178 zwischen 0,05 und 0,10 liegt. Liegt der Wert in F178 außerhalb dieses Bereiches bleibt die Zelle leer. Es wird auch keine 0 (Null) angezeigt. Die letzten beiden Anführungsstriche sorgen dafür, dass in der Zelle nichts angezeigt wird.

    Sobald aber der Wert in F178 zwischen 0,05 und 0,10 liegt (auch aus automatischen Berechnungen) wird die 1 angezeigt. Anstelle der 1 kann natürlich auch 'was anderes (steht zwischen den beiden ; ; ) angezeigt werden.

    Ich nutze diese Funktion in Aufmaßblättern um bei Null-Werten aus optischen Gründen ein leeres Feld zu erzeugen anstelle dort eine "0" oder "0,00" stehen zu haben.
    Gruß
    Holger
    --
    Früher, da war vieles gut. Heute ist alles besser.
    Manchmal wäre ich froh, es wäre wieder gut.
    (Andreas Marti; Schweizer)
  • Danke Holger
    Mir geht es aber um das Ausblenden ganzer Zeilen und Passagen.
    Ich bin mit dem schlimmsten Teil fertig.
    Durch etwas Trickserei geht das über Autofiltern.
    Muss nur dafür sorgen das irgendwie in den auszublendenden Zeilen "nichts" oder in allen das selbe steht.
    Für die einfache Aufgabe musste ich nun in Untiefen absteigen (eigentlich aufsteigen) die kannte ich gar nicht.

    Momentan hänge ich bei einem Problem fest:
    Ich will das Wort "Titel" in die Zelle der Spalte D stehen haben wo in der Spalte E ein eingefärbte Zelle ist.
    Momentan habe ich ein gefundenes Makro, welches dummerweise die ganze Spalte D mit dem Wörtchen "Titel: " überzieht.
    Ich möchte aber, wenn z.B. die Zelle E12 gelb ist, dass dann in D12 das Wort "Titel: " steht (+Schrift = fett)

    Das ist das Makro

    Quellcode

    1. Sub FarbigeZellen()
    2. Dim rngSpalte As Range
    3. Dim rngZeile As Range
    4. Dim blnFarbe As Boolean
    5. For Each rngSpalte In Application.Intersect(Range("D:D"), Me.UsedRange)
    6. For Each rngZeile In Application.Intersect(Range(rngSpalte.Offset(0, 1), _
    7. Cells(rngSpalte.Row, Me.Columns.Count)), Me.UsedRange)
    8. If rngZeile.Interior.ColorIndex <> -4142 Then
    9. blnFarbe = True
    10. Exit For
    11. End If
    12. Next 'rngZeile
    13. If blnFarbe Then
    14. rngSpalte = "Titel: "
    15. blnFarbe = False
    16. End If
    17. Next 'rngSpalte
    18. End Sub
    Alles anzeigen
    öffentlich bestellter und vereidigter Sachverständiger für das Maurer- und Betonbauerhandwerk