Hilfe bei Makro

[Patrick1306]

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 :)

[cysu11]

Hallo Patrick,


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

LG
Alexandra

[Patrick1306]

hoffe es bringt was ;)

[schauan]

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