ich habe folgendes Makro bzw. Button, welches mir eine Kopie vom Reiter "F1" eines Excelsheets erstellt und diesen in einem Ordner abspeichert...Desweiteren werden bestimmte Excelzellen in eine Datei auf dem Desktop übertragen.
Jetzt möchte ich aber noch folgendes erreichen:
Wenn der Button gedrückt wird, soll erstmal überprüft werden, ob in den Zellen EK6,ES6,EK8 und ES8 Zahlenwerte vorhanden sind. Wenn dies nicht der Fall ist, soll das oben beschriebene Makro nicht ausgeführt werden und stattdessen eine Fehlermeldung kommen, die den Inhalt hat, dass diese Zellen ausgefüllt werden müssen.
Könnt ihr mir hier weiterhelfen? Hier noch mein Makro:
Option Explicit
' Button drücken und Excelsheet erstellen
Private Sub CommandButton1_Click()
CommandButton1.BackColor = RGB(255, 135, 0)
Dim sWBName As String
Dim SubPathName As String
Dim NewWBName As String
Dim sh As Shape, lX As Long
GetMoreSpeed True
SubPathName = "\" & Format(Cells(1, 1), "MMMM YYYY") & "\"
NewWBName = Me.Name & "_" & Cells(1, 1).Text & ".xlsx"
UsedRange.Copy
MakeSureDirectoryPathExists (ThisWorkbook.Path & SubPathName)
Workbooks.Add
With ActiveWorkbook
With .Worksheets(1)
.Name = Me.Name
.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
' Diagramme auch übernehmen
On Error Resume Next
For Each sh In Me.Shapes
If Left(sh.Name, 6) = "Chart " Then
sh.Copy
.PasteSpecial Format:="Bild (GIF)", Link:=False, DisplayAsIcon:=False
Do While Err.Number 0
Application.Wait (Now + TimeValue("0:00:01"))
Err.Clear
.PasteSpecial Format:="Bild (GIF)", Link:=False, DisplayAsIcon:=False
Loop
lX = lX + 1
.Shapes(lX).Left = sh.Left
.Shapes(lX).Top = sh.Top
End If
Next sh
On Error GoTo 0
Application.CutCopyMode = False
.Range("IM11,IM19,IM24,IM29,IM35").Copy
Call subSaveIM11
End With '
Application.DisplayAlerts = False
Do While .Worksheets.Count > 1
.Worksheets(2).Delete
Loop
Application.DisplayAlerts = True
sWBName = ThisWorkbook.Path & SubPathName & NewWBName
.SaveAs sWBName
.Close
End With
Application.CutCopyMode = False
MsgBox "Daten gespeichert unter" & vbCrLf & _
sWBName, vbOKOnly + vbInformation
GetMoreSpeed False
End Sub
Sub subSaveIM11()
Dim wkbOverview As Workbook
Dim loLetzte As Long
Set wkbOverview = Application.Workbooks.Open(Filename:="C:\Users\arek\Desktop\Beispiel.xlsx")
With wkbOverview.Worksheets("Overview")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(loLetzte, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wkbOverview.Close savechanges:=True
End With
End Sub