Clever-Excel-Forum

Hallo Liebe Com,

ich habe bisher kaum Erfahrung gemacht mit den Makros und bitte euch um Hilfe.

Habe folgendes Problem:

Und zwar habe ich eine Makro geschrieben siehe unten. Jetzt muss ich aber in den neu erstellten Blättern "Pflege", "Ortho", "Anästhesie" einen Zellbezug zu dem Sheet Aufnahme erstellen.
Das Makro soll das direkt beim einfügen übernehmen und den Zellbezug herstellen.

Im Grunde eine simple Suchen und ersetzten funktion von "Aufnahme KW a" durch "Aufnahme KW b"

Ich hoffe ihr versteht was ich meine.

Code:
Sub AufnahmeSheet()

Dim a, b As Integer

Dim X As Date

Tabelle1.Visible = True

    a = InputBox("Bitte KW eingeben")

    b = Year(Date)

        On Error GoTo FEHLERMELD

            X = DateSerial(b, 1, 7 * a) - 3 - Weekday(DateSerial(b, 0, 0), 2) + 1

            Y = DateSerial(b, 1, 7 * a) - 3 - Weekday(DateSerial(b, 0, 0), 2) + 2

            Z = DateSerial(b, 1, 7 * a) - 3 - Weekday(DateSerial(b, 0, 0), 2) + 3

            D = DateSerial(b, 1, 7 * a) - 3 - Weekday(DateSerial(b, 0, 0), 2) + 4

            S = DateSerial(b, 1, 7 * a) - 3 - Weekday(DateSerial(b, 0, 0), 2) + 5

                Tabelle1.Copy after:=Sheets(Sheets.Count)

            ActiveSheet.Name = "Aufnahme KW " & a & X

        ActiveSheet.Range("A2") = "KW" & a

        ActiveSheet.Range("B2") = X

        ActiveSheet.Range("D2") = Y

        ActiveSheet.Range("F2") = Z

        ActiveSheet.Range("H2") = D

        ActiveSheet.Range("J2") = S

    ActiveSheet.Name = "Aufnahme KW " & a & " " & X

        GoTo FINI

FEHLERMELD:

    Application.DisplayAlerts = False

    ActiveSheet.Delete

    MsgBox "Diese Tabelle existiert schon"

FINI:

    Tabelle1.Visible = False

    Application.DisplayAlerts = True

Sheets("Pflege KW17").Copy after:=Sheets(Sheets.Count)

    Worksheets(Worksheets.Count).Name = "Pflege KW" & a

Sheets("Ortho KW17").Copy after:=Sheets(Sheets.Count)

    Worksheets(Worksheets.Count).Name = "Ortho KW" & a

Sheets("Anästhesie KW17").Copy after:=Sheets(Sheets.Count)

    Worksheets(Worksheets.Count).Name = "Anästhesie KW" & a

End Sub

Vielen Dank :)

Hallo Patrick,

lade doch mal deine Datei hoch, dann kann Dir leichter geholfen werden!

LG
Alexandra

hoffe es bringt was ;)

Hallöchen,

auch mal ein Ansatz ohne Datei:
Aufgezeichnet allgemein zum Suchen & Ersetzen bekommt man z.B. diesen Code:

Code:
Sub Makro3()

'

' Makro3 Makro

'

'

    Range("A1:A4").Select

    Selection.Replace What:="Tabelle2", Replacement:="Tabelle3", LookAt:= _

        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

End Sub

Du könntest das bei Dir für die entsprechenden Zellen und Worte entsprechend machen. Dann wird der Code noch etwas eingekürzt:

Code:
Sub Makro3()

    Range("A1:A4").Replace What:="Tabelle2", Replacement:="Tabelle3", LookAt:= _

        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

End Sub

… und auf die Variable a und Deine Blattnamen angepasst:

Code:
Sub Makro3()

    a=InputBox("Bitte KW eingeben")

    '... Dein Code, bis nach dem Einfuegen und umbenennen der Blaetter

    'koennte z.B. in Deinem FINI-Teil am Ende - vor End Sub - ran 

    Range("A1:A4").Replace What:="Aufnahme KW " & a-1, Replacement:="Aufnahme KW " & a, LookAt:= _

        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

End Sub

Patrick1306

cysu11

Patrick1306

schauan