vba tabellenkalkulation

Question

Hallo Leute ,

ich habe ein riesen problem.
Mit meiner marko kann ich auf einmal meine eingelesenen daten leider nicht mehr in eine andere datei hinein kopieren.

kann mir mir jemand dabei bitte helfen?

Gruß Marko

Sub DUMMYDATABASE()
Dim anw
Dim Pfad As String
Dim Datei As String
Dim i As Long
Dim shExists As Boolean
Dim lz As Long
Dim Ziel As String
Dim iZiel As String
Dim wbk As Workbook

'
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Pfad anpassen
'Pfad = "C:\Users\........\Desktop\DATABASE\Orders\" & ORDERSHEET & ".xlsx"

inputname:
Ziel = InputBox("please select any ORDERSHEET (for example ORDERSHEET_A1 or ORDERSHEET_B1), in order to obtain the important information related to the choosen product number, all information will be send automatically to the new ORDERSHEET !", Ziel)

If Ziel = "" Then
anw = MsgBox("Invalid name! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If

'Endung ggf. anpassen
Ziel = Ziel & ".xlsx"
Datei = Pfad & Ziel

If Dir(Datei) = "" Then
anw = MsgBox("The file " & Ziel & " doesn't exist! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If

'Zieldatei öffnen
Workbooks.Open Filename:=Datei

Set wkb = Workbooks.Open(Filename:=Datei)

For i = 1 To wkb.Worksheets.Count
If wkb.Worksheets(i).Name = "Tabelle 1" Then shExists = True
Next i

'Falls nein, dann Meldung und Abbruch
If shExists = False Then
MsgBox "The Worksheet Tabelle 1 doesn't exit in the Workbook named " & wkb.Name & "! Abort!", 16, "Error"
Exit Sub
End If

ThisWorkbook.Sheets("DASHBOARD").Range("E4:I14").copy 'kopieren
With wkb

.Worksheets("Tabelle 1").Range("B4:F14").PasteSpecial Paste:=xlPasteValues 'Nur Werte einfÙgen
.Close (True) 'speichern und schlie_en
End With

Application.CutCopyMode = False '

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

MsgBox "the informations are send to the new ordersheet !", 64, "Copy finished"
Set wkb = Workbooks.Open(Filename:=Datei)

End Sub

Answer 1

Hi Marko,
da ich leider kein VBA-Spezialist bin, kann ich Dir zu Deinem Makro nichts sagen, aber wenn ich Dich richtig verstanden habe, hat es zu einem früheren Zeitpunkt x funktioniert.

Wenn Du zwischenzeitlich keine Veränderung am Makro selbst vorgenommen hast, was hier keiner erkennen kann, gibt es ja nur die Möglichkeit, dass sich an Deiner Arbeitsumgebung etwas verändert hat.

Leider hast Du ja auch nicht geschrieben, an welcher Stelle Dein Makro nicht mehr läuft bzw. ob es gar nicht mehr startet.

Von daher geht mein Denkansatz in diese Richtung und Du solltest Dich fragen, was sich seit dem letzten Zeitpunkt, in dem das Makro noch funktioniert hat und dem jetzigen Zeitpunkt geändert hat.

Mögliche Veränderungen wären:
Speicherort wurde geändert und müsste im Makro angepasst werden
Ich selbst habe Probleme mit nicht mehr laufenden Makros gehabt, als wir von Excel 2003 zu 2013 gewechselt haben (siehe meinen Thread - https://supportnet.de/t/2487339).
Speicherort wurde geändert und von Dir angepasst, aber die Zugriffsrechte auf den Ordner zum Speichern bzw. Lesen fehlen.

In der Hoffnung Dir evtl. ein wenig geholfen zu haben.... have a nice Day... Lg Helmut

Answer 2

Hallo Marko,

da du deinen Code offensichtlich für die Frage verfremdet hast, ist
es schwer ohne nähere Informationen eine Aussage zu treffen. So
wie oben gezeigt, kann er jedenfalls nicht funktionieren. Wie Helmut
bereits schrieb, kann man daher nur raten, wo das Problem liegen
könnte.

[list=1]
[*]Dein Pfad wird aufgrund des führenden Apostrophs nicht
ausgewertet. Dadurch wird die Datei nicht gefunden und Excel
springt immer wieder zurück zur Dateieingabe. Die Zeile sollte
lauten:
Pfad = "C:\Users\DeinName\Desktop\DATABASE\Orders\"
[*]Wenn du deiner Inputbox einen Standardwert mitgeben willst,
muss du der Variable ORDERSHEET zurnächst einen Dateinamen
(ohne xlsx) zuweisen, und dann die zeile Inputbox um den dritten
Parameter erweitern.
Ziel = InputBox("DeinText", Ziel, ORDERSHEET)
[*]Die Ausgabedatei muss bereits existieren, sonst kann sie nicht
gefunden werden.
[*]Warum öffnest du die Datei gleich zweimal? Es reicht wenn du die
Datei mit Set wkb = Workbooks.Open(Filename:=Datei) öffnest, die
vorherige Zeile kannst du löschen.
[*]in der nächsten Schleife suchst du ob die Tabelle existiert.
Allerdings lautet der Standard Sheetname von Excel immer Tabelle1
(also ohne Leerzeichen). Wenn du mit Leerzeichen suchst, wird das
Sheet womöglich nicht gefunden.
[*]Warum schließt du die Ausgabedatei um sie nach
Erfolgsmeldung (Msgbox) dann wieder zu öffnen? Ich würde die
letzte Zeile löschen, und dafür auf das .Close True verzichten.
Speichern kannst du auch mit .Save
[/list]
Vielleicht hilft dir das ja ein wenig weiter.
Gruß Mr. K.

Answer 3

hi all ^^

ein wenig umgeschrieben

vielleicht kommt er der Fragestellung nah

gruss nighty

Sub DatenSchreiben()
Dim DateiName As String, DateiName2 As String
Dim QuelleB As String, ZielB As String
Dim QuelleT As String, ZielT As String
DateiName = Application.GetOpenFilename("xls Files (*.xls),*.xls", 1)
DateiName2 = Mid(DateiName, InStrRev(DateiName, "\") + 1, Len(DateiName) - InStrRev(DateiName, "\"))
QuelleT = "Tabelle1" '"DASHBOARD"
QuelleB = "A1:A2"
ZielT = "Tabelle1"
ZielB = "A1"
If DateiName <> "Falsch" Then
Workbooks.Open Filename:=DateiName
If SheetExists(ZielT) = True Then
ThisWorkbook.Worksheets(QuelleT).Range(QuelleB).Copy
Workbooks(DateiName2).Worksheets(ZielT).Range(ZielB).PasteSpecial Paste:=xlValues, Operation:=xlNone
End If
Workbooks(DateiName2).Close SaveChanges:=True
End If
End Sub

Public Function SheetExists(strName As String) As Boolean
On Error Resume Next
SheetExists = Not Worksheets(strName) Is Nothing
End Function

Answer 4

hi all ^^

anzupassen waere

QuelleT = "Tabelle1" '"DASHBOARD"
QuelleB = "A1:A2"
ZielT = "Tabelle1"
ZielB = "A1"

gruss nighty