AW: auttomatische datenblätter automatisch abfüllen
15.01.2018 11:33:34
simon
so, nochmals ich
ich benötige nur noch den VBA Code, welcher mir in der Spalte B5 jeweils den Blattnamen automatisch einfügt...
lg simu
Option Explicit
Sub NeuesBlatt_erstellen()
Dim Zeile As Long
Dim wksListe As Worksheet
Dim wksDaten As Worksheet
Dim wksVorlage As Worksheet
Set wksListe = ActiveWorkbook.Worksheets("Mängelliste")
Set wksVorlage = ActiveWorkbook.Worksheets("Vorlage")
If ActiveSheet.Name wksListe.Name Then
MsgBox "Das Makro ""NeuesBlatt_erstellen"" nur Starten, wenn das Blatt """ _
& wksListe.Name & """ das aktive Blatt ist!", _
vbInformation + vbOKOnly, "Hinweis"
GoTo Beenden
End If
Zeile = ActiveCell.Row
If Trim(wksListe.Cells(Zeile, 1).Text) = "" Then
MsgBox "In Spalte A der aktiven Zeile ist noch keine Mangel-Nr. eingetragen!", _
vbInformation + vbOKOnly, "Makro: NeuesBlatt_erstellen"
ElseIf fncCheckSheet(wksListe.Cells(Zeile, 1).Text, ActiveWorkbook) = True Then
MsgBox "Das Blatt zur Mangel-Nr. """ & wksListe.Cells(Zeile, 1).Text _
& """ ist bereits vorhanden!", _
vbInformation + vbOKOnly, "Makro: NeuesBlatt_erstellen"
Else
If MsgBox("Neues Blatt für Mangel Nr, """ & wksListe.Cells(Zeile, 1).Text & """ _
erstellen?", _
vbQuestion + vbOKCancel, "Mängel-Datenblatt erstellen") = vbCancel Then GoTo _
Beenden
wksVorlage.Copy before:=wksVorlage
Set wksDaten = ActiveSheet
wksDaten.Name = wksListe.Cells(Zeile, 1).Text
wksDaten.Range("B5").Value = wksListe.Cells(Zeile, 1).Value 'Mangel-Nr. eintragen
End If
Beenden:
End Function
Sub Daten_in_Mangelblatt_eintragen()
Dim Zeile As Long
Dim strBlatt As String
Dim wksListe As Worksheet
Dim wksDaten As Worksheet
Dim wksVorlage As Worksheet
Set wksListe = ActiveWorkbook.Worksheets("Mängelliste")
Set wksVorlage = ActiveWorkbook.Worksheets("Vorlage")
If ActiveSheet.Name wksListe.Name Then
MsgBox "Das Makro ""Daten_in_Mangelblatt_eintragen"" nur Starten, wenn das Blatt """ _
& wksListe.Name & """ das aktive Blatt ist!", _
vbInformation + vbOKOnly, "Hinweis"
GoTo Beenden
End If
Zeile = ActiveCell.Row
strBlatt = wksListe.Cells(Zeile, 1).Text
If Trim(strBlatt) = "" Then
MsgBox "In Spalte A der aktiven Zeile ist noch keine Mangel-Nr. eingetragen!", _
vbInformation + vbOKOnly, "Makro: Daten_in_Mangelblatt_eintragen"
End If
If fncCheckSheet(strBlatt, ActiveWorkbook) = True Then
Set wksDaten = ActiveWorkbook.Worksheets(strBlatt)
Else
If MsgBox("Das Blatt zur Mangel-Nr. """ & strBlatt & """ ist noch nicht angelegt!" _
& vbLf & "Neues Blatt jetzt erstellen?", _
vbQuestion + vbOKCancel, "Makro: Daten_in_Mangelblatt_eintragen") = vbOK Then
wksVorlage.Copy before:=wksVorlage
Set wksDaten = ActiveSheet
wksDaten.Name = strBlatt
wksDaten.Range("B5").Value = wksListe.Cells(Zeile, 1).Value 'Mangel-Nr. eintragen
End If
End If
If Not wksDaten Is Nothing Then
'Daten aus Liste in Blatt übertragen
With wksDaten
.Range("G5").Value = wksListe.Cells(Zeile, 2) 'Datum
.Range("B17").Value = wksListe.Cells(Zeile, 3) 'Gebäude
.Range("B19").Value = wksListe.Cells(Zeile, 4) 'Ebene
.Range("B21").Value = wksListe.Cells(Zeile, 5) 'Achse Sektor Raum
.Range("G7").Value = wksListe.Cells(Zeile, 6) 'Mangel
End With
End If
Beenden:
End Sub
Public Function fncCheckSheet(varBlatt, Optional Wb As Workbook) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
Dim objSheet As Object
On Error GoTo Fehler
If Wb Is Nothing Then Set Wb = ActiveWorkbook
Set objSheet = Wb.Sheets(varBlatt)
fncCheckSheet = True
Exit Function
Fehler:
fncCheckSheet = False
End Function