ich habe folgendes Makro, welches mir zum einen das Tabellenblatt in einem Ordner mit dem Namen des Tabellenblatts und dem entsprechenden Datum abspeichert und zum anderen die Daten aus den Zellen IM19,IM24,IM29,IM35 in eine Beispielsdatei auf dem Desktop überträgt...Nun meine Frage: Im Moment werden die Daten aus den Zellen IM19,IM24,IM29,IM35 in die Spalten A,B,C und D übertragen...Ich möchte allerdings erreichen, dass diese in die Spalten E,F,G und H übertragen werden. Hier mein aktueller Code:
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("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 Kann mir hier jemand weiterhelfen?Vielen Dank im Voraus!