Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1624to1628
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Daten in andere Spalten übertragen
04.06.2018 11:25:21
arek
Hallo zusammen,
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!

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten in andere Spalten übertragen
04.06.2018 16:24:13
Robert
Hallo arek,
ändere nachstehende Zeile in der Sub subSaveIM11() wie folgt(Änderung in rot):
.Cells(loLetzte, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Gruß
Robert
AW: Daten in andere Spalten übertragen
04.06.2018 17:34:14
kathrin
Hi Robert,
danke für deine Antwort! Das funktioniert!
Jetzt hätte ich allerdings noch ein Anliegen und zwar habe ich in Zelle A1 das aktuelle Datum mit der heute()-Formel stehen und dieses soll in Spalte B analog übertragen werden und die anderen Daten wie gehabt in Spalten E bis H stehen...Desweiteren soll in Spalte A der Tabellenblattname kopiert werden...
Kannst du mir da nochmals weiterhelfen bitte?
Anzeige
AW: Daten in andere Spalten übertragen
04.06.2018 18:37:04
Robert
Hallo arek,
ändere nachstehende Zeile in der Sub CommandButton1_Click() wie folgt
Call subSaveIM11(.name)
und die subSaveIM11() wie folgt
Sub subSaveIM11(strSName As String)
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
'Tabellenname in Spalte A einfügen
.Cells(loLetzte, 1) = strSName
'Aktuelles Datum in Spalte B einfügen
.Cells(loLetzte, 2) = Date
.Cells(loLetzte, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wkbOverview.Close savechanges:=True
End With
End Sub

Gruß
Robert
Anzeige
AW: Daten in andere Spalten übertragen
05.06.2018 11:08:42
arek
Hi Robert,
danke das funktioniert super!...Jetzt hätte ich noch eine Frage: Im Moment erstelle ich mit dem Code eine Kopie des Tabellenblattes, wobei die Diagramme als Bilder übernommen werden...Ich möchte allerdings eine "echte" Kopie erstellen, wo eins zu eins eine ´Kopie des Tabellenblattes vorhanden ist...Kannst du mir diesbezüglich nochmals helfen? Das wäre sehr hilfreich!
Hier nochmal 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(.Name)
.Range("DG24,DG26,DG28").Copy
Call subSaveIM12
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(strSName As String)
Dim wkbOverview As Workbook
Dim loLetzte As Long
Set wkbOverview = Application.Workbooks.Open(Filename:="C:\Users\arek\Desktop\Beispiel.xlsx")
With wkbOverview.Worksheets("Overview1")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Tabellenname in Spalte A einfügen
.Cells(loLetzte, 1) = strSName
'Aktuelles Datum in Spalte B einfügen
.Cells(loLetzte, 2) = Date
.Cells(loLetzte, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wkbOverview.Close savechanges:=True
End With
End Sub Sub subSaveIM12()
Dim wkbOverview As Workbook
Dim loLetzte As Long
Set wkbOverview = Application.Workbooks.Open(Filename:="C:\Users\arek\Desktop\Beispiel.xlsx")
With wkbOverview.Worksheets("Overview2")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(loLetzte, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wkbOverview.Close savechanges:=True
End With
End Sub
Anzeige
AW: Daten in andere Spalten übertragen
05.06.2018 13:53:49
Robert
Hallo arek,
ich habe es mal versucht. Mit einer Beispieldatei wäre es etwas einfacher gewesen. So musste ich versuchen, Deinen Code richtig zu interpretieren. Wenn ich ihn richtig verstanden habe, wird beim Klick auf den Button im Formular eine neue Datei angelegt und die Diagramme des aktiven Tabellenblattes dort als Bild eingefügt. Anschließend werden noch Daten in eine Datei, die auf dem Desktop liegt gespeichert.
Nachstehendes Makro müsste diese Aufgaben erledigen. Die vormals in ausgelagerten Subs durchgeführte Änderungen in der Datei auf dem Desktop, habe ich integriert. Die komplette Datei(en) nachzubauen, um das Makro zu testen, war mir allerdings etwas zu aufwändig, zumal ja auch noch Sub gestartet werden, die mir nicht vorliegen (GetMoreSpeed, MakeSureDirectoryPathExists). Das Makro zu testen wäre jetzt Deine Aufgabe.
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
Dim wkbQ As Workbook, wksQ As Worksheet
Dim wkbOverview As Workbook
Dim loLetzte As Long
GetMoreSpeed True
SubPathName = "\" & Format(Cells(1, 1), "MMMM YYYY") & "\"
NewWBName = Me.Name & "_" & Cells(1, 1).Text & ".xlsx"
MakeSureDirectoryPathExists (ThisWorkbook.Path & SubPathName)
'Aktuelle Tabellekopieren
ActiveSheet.Copy
Set wkbQ = ActiveWorkbook
Set wksQ = ActiveSheet
With wkbQ
With .wksQ
.Name = Me.Name
'Daten auf Desktop aktualisieren
Set wkbOverview = Application.Workbooks.Open(Filename:="C:\Users\arek\Desktop\Beispiel. _
xlsx")
'alt: subSaveIM11
.Range("IM19,IM24,IM29,IM35").Copy
With wkbOverview.Worksheets("Overview1")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Tabellenname in Spalte A einfügen
.Cells(loLetzte, 1) = .Name
'Aktuelles Datum in Spalte B einfügen
.Cells(loLetzte, 2) = Date
.Cells(loLetzte, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'alt: subSaveIM12
.Range("DG24,DG26,DG28").Copy
With wkbOverview.Worksheets("Overview2")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(loLetzte, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'Datei auf Desktop schließen
wkbOverview.Close savechanges:=True
End With
sWBName = ThisWorkbook.Path & SubPathName & NewWBName
.SaveAs sWBName
.Close
End With
Set wkbQ = Nothing
Set wksQ = Nothing
Set wkbOverview = Nothing
MsgBox "Daten gespeichert unter" & vbCrLf & sWBName, vbOKOnly + vbInformation
GetMoreSpeed False
End Sub

Gruß
Robert
Anzeige
AW: Daten in andere Spalten übertragen
05.06.2018 14:32:42
arek
Hi Robert,
vielen Dank für deine Antwort!! Leider kommt noch folgende Fehlermeldung: "Laufzeitfehler 438 Objekt unterstützt diese Eigenschaft oder Methode nicht" und markiert dabei "With .wksQ" gelb...Kannst du mir da nochmal weiterhelfen? Nochmals vielen Dank!!!!
AW: Daten in andere Spalten übertragen
05.06.2018 14:42:37
Robert
Hallo arek,
versuche es mal ohne den Punkt

With wksQ
Gruß
Robert
AW: Daten in andere Spalten übertragen
05.06.2018 15:38:55
arek
Hi Werner,
nochmals danke!! Eine Kleinigkeit ist allerdings noch bei dem Makro: Es funktioniert nun alles wie ich mir vorstelle, allerdings wird in Spalte A nicht der Name des Tabellenblattes (in meiner Datei: F1), das kopiert wird eingefügt, sondern der Name des Tabellenblattes (in meiner Datei: Overview1), wo die Daten dann eingefügt werden, d.h. es steht im Moment Overview1 und nicht F1 in der Spalte...Hast du mir dazu noch einen Tipp?
Eine allerletzte Frage hätte ich noch und zwar habe ich ja den Button und das dazugehörige Makro von dir jetzt, allerdings soll dieser ganze Prozess erst dann losgehen, wenn in den Zellen EK6, EK8, ES6 und ES8 auch wirklich Zahlenwerte eingetragen sind und diese auch ausgefüllt sind. Ansonsten wenn das nicht der Fall ist, soll beim Drücken des Buttons der ganze Prozess nicht gestartet werden und die Fehlermeldung "Bitte ausfüllen" kommen...Könntest du mir da nochmals helfen? Das wäre echt hilfreich!!!
Anzeige
Mein Fehler
05.06.2018 16:20:37
Robert
Hallo arek,
stimmt, war mein Fehler. Ich habe einen With-Block übersehen. Ändere nachtehende Zeile wie folgt, dannn müsste es klappen.
.Cells(loLetzte, 1) = wksQ.Name
Wenn Du nachstehende Zeilen ganz am Anfang einfügst, wird das Makro mit einem entsprechenden Hinweis sofort beendet, wenn eine oder mehrere der genannten Zellen keine Zahl enthält.
If Application.WorksheetFunction.Count(Range("EK6, EK8, ES6, ES8")) 

Gruß
Robert

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige