AW: Excell Tabellenblätter mit Userform erstellen
21.09.2018 15:19:09
M.Steiner
Guten Tag Werner
Vielen Dank für die schnelle Antwort
Hier mein Code:
Private Sub CommandButton1_Click()
'F?gt eingetragene Werte in die n?chste leere Zeile und schliesst das Fenster
Dim intErsteLeereZeile As Long
'Dim i As Integer
ActiveSheet.Unprotect ("***")
intErsteLeereZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
intletztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Select
ActiveCell.Offset(1, 0) = ActiveCell + 1 'f?gt numerierung ein
With Sheets("Kellerbuch")
.Cells(intErsteLeereZeile, 4).Value = Me.txtErntedatum.Value
.Cells(intErsteLeereZeile, 3).Value = ListBox1.Value
.Cells(intErsteLeereZeile, 2).Value = Me.cboLieferant.Value + " " + Txtaddresse2.Value + _
", " + txtaddresse4 + " " + txtaddresse5
.Cells(intErsteLeereZeile, 6).Value = Me.cboSorten.Value
.Cells(intErsteLeereZeile, 7).Value = Me.ListBox2.Value
.Cells(intErsteLeereZeile, 12).Value = Me.txtOechsle.Value
.Cells(intErsteLeereZeile, 11).Value = Me.txtKilo.Value
.Cells(intErsteLeereZeile, 18).Value = Me.txtAnmerkungen.Value
.Cells(intErsteLeereZeile, 5).Value = Me.CboWeinname.Value
.Cells(intErsteLeereZeile, 8).Value = Me.cbotraubenherkunft.Value
.Cells(intErsteLeereZeile, 10).Value = Me.txtbarrique.Value
.Cells(intErsteLeereZeile, 15).FormulaR1C1 = "=RC[-1]/RC[-4]" 'formel ausbeute ohne _
verschnitte
.Cells(intErsteLeereZeile, 13).FormulaR1C1 = "=RC[-2]*R5C13" 'formel theoretiesche _
ausbeute
.Cells(intErsteLeereZeile, 14).FormulaR1C1 = "=INDIRECT(""'""&RC[-13]&""'!F34"")"
.Cells(intErsteLeereZeile, 16).FormulaR1C1 = "=INDIRECT(""'""&RC[-15]&""'!F6"")"
.Cells(intErsteLeereZeile, 17).FormulaR1C1 = "=INDIRECT(""'""&RC[-16]&""'!F7"")"
.Cells(intErsteLeereZeile, 19).FormulaR1C1 = "=YEAR(RC[-15])"
.Cells(intErsteLeereZeile, 9).Value = Me.cboWeinart.Value
.Cells(intErsteLeereZeile, 20).Value = Me.cboLieferant.Value
End With
'f?gt tabellenblatt pro Wein ein
Dim LastRow As Long
Dim i As Long
Dim BoVorhanden As Boolean
Dim Ws As Worksheet
Dim Blattname As String
Application.ScreenUpdating = False
With Sheets("Kellerbuch")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 8 To LastRow
Blattname = .Cells(i, 1).Value
On Error Resume Next
Sheets(Blattname).Select
If Err.Number = 9 Then
Sheets("Weinbuchvorlage").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Sheets("Kellerbuch").Range("A" & i)
.Range("B5") = Sheets("Kellerbuch").Range("B" & i)
.Range("B6") = Sheets("Kellerbuch").Range("H" & i)
.Range("F8") = Sheets("Kellerbuch").Range("A" & i)
.Range("B8") = Sheets("Kellerbuch").Range("F" & i)
.Range("B7") = Sheets("Kellerbuch").Range("E" & i)
.Range("D7") = Sheets("Kellerbuch").Range("C" & i)
.Range("B9") = Sheets("Kellerbuch").Range("D" & i)
.Range("F5") = Sheets("Kellerbuch").Range("G" & i)
.Range("D9") = Sheets("Kellerbuch").Range("I" & i)
.Range("F9") = Sheets("Kellerbuch").Range("J" & i)
.Range("D8") = Sheets("Kellerbuch").Range("K" & i)
.Range("D6") = Sheets("Kellerbuch").Range("L" & i)
End With
Else
'nix machen
End If
On Error GoTo 0
Next
End With
Sheets("Kellerbuch").Select
Application.ScreenUpdating = True
Dim r As Long
r = Range("A65536").End(xlUp)
MsgBox ("Die Weinnr. ist ") & r
ActiveSheet.Protect ("***")
ActiveWorkbook.Save
Unload Me
End Sub
Vielen Dank
M.Steiner