Makro ergänzen: Datenexport in anderes Tabellenbla
09.05.2018 10:31:17
arek
ich habe einen Button mit einem Macro programmiert, welcher mir wenn man ihn drückt das Tabellenblatt kopiert und dieses in einem Ordner mit "Monat/Jahresangabe" abspeichert und zwar unter dem Dateinamen mit "Name Tabellenblatt/Datum". Jetzt würde ich gerne das Macro noch um folgendes ergänzen: Wenn der Button gedrückt wird, soll nachwievor die Kopie des Tabellenblattes erstellt werden und gleichzeitig soll aber Zelle IM11 in ein Tabellenblatt "Overview" in Zelle B3 gespeichert werden (dieses Tabellenblatt ist Teil eines Excelsheets auf meinem Desktop)...
Hat hierzu jemand eine Idee?Vielen Dank!!
Hier wäre noch mein VBA-Code:
Option Explicit
' Button drücken und Excelsheet erstellen
Private Sub CommandButton1_Click()
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
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
Option Explicit
' Standardmodul
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'
' GetMoreSpeed
'
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
Static intCalculation As Integer
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub