Supportnet / Forum / Tabellenkalkulation
Anfänger benötigt Hilfe für Mako in Exel
Frage
Hallo User, Problem Makro
Ich habe ein grosses Problem und hoffe hier auf Hilfe. Ich habe hunderte von alten Excel-Datein und soll diese in eine andere Tabelle bringen (also pro Excel-Datei eine neue mir vorgegebene Tabelle (Mustertabelle)).
In der ursprünglichen Excel-Datei steht z.B in A:7
"Datum :01.08.2005"
In die Mustertabelle soll nur das Datum als
"01.08.2005"
In der ursprünglichen Excel-Datei steht z.B in A:16
"Zähler :0001"
In die Mustertabelle soll nur "0001"
Nachdem diese und ähnliche Werte in die neue Mustertabelle übernommen sind, soll diese unter folgendem Namen abgespeichert werden
Inhalt von A:16 vom A:7 also
"0001 vom 01_08_2005.xls"
Danach die nächste alte Tabelle in eine neue Mustertabelle u.s.w
Ich bin für jeden Tip dankbar
MfG Emmis
Antwort 1 von JoeKe
Hallo Emmis,
Nimm dir viel Zeit! ;-))))
Ne mal im Ernst wird ne menge Handarbeit.
Aber was dir eventuell einen Teil der Arbeit abnehmen könnte wäre der Konvertierungs-Assistent "Text in Spalten...." .
MfG
JöKe
Nimm dir viel Zeit! ;-))))
Ne mal im Ernst wird ne menge Handarbeit.
Aber was dir eventuell einen Teil der Arbeit abnehmen könnte wäre der Konvertierungs-Assistent "Text in Spalten...." .
MfG
JöKe
Antwort 2 von Event
Hallo Emmis
Ist das immer derselbe Bereich("A7:A16") der importiert werden soll und welche Gemeinsamkeiten bzw. Unterschiede haben die Namen der Quelldateien, sind die Dateien strukturell identisch usw.
Ohne weiterführende Angaben Deinerseits kann sonst kein Ansatz gemacht werden.
Gruß
Ist das immer derselbe Bereich("A7:A16") der importiert werden soll und welche Gemeinsamkeiten bzw. Unterschiede haben die Namen der Quelldateien, sind die Dateien strukturell identisch usw.
Ohne weiterführende Angaben Deinerseits kann sonst kein Ansatz gemacht werden.
Gruß
Antwort 3 von Emmis
Es ist immer der Inhalt des Feldes A7 und A16 der alten Tabellen die in die Mustertabelle übernommen werden sollen.
Sorry, habe mich sehr verwirrend ausgedrückt.
Nochmals
In der ursprünglichen Excel-Datei steht z.B in A7
"Datum :01.08.2005"
In die Mustertabelle soll nur das Datum in C16
"01.08.2005" in C16
In der ursprünglichen Excel-Datei steht z.B in A16
"Zähler :0001"
In die Mustertabelle soll nur "0001" in C20
Nachdem diese und ähnliche Werte in die neue Mustertabelle übernommen sind, soll diese unter folgendem Namen abgespeichert werden
Inhalt von C20 vom C16 der Mustertabelle also
"0001 vom 01_08_2005.xls"
Danach die nächste alte Tabelle in eine neue Mustertabelle u.s.w
Sorry, habe mich sehr verwirrend ausgedrückt.
Nochmals
In der ursprünglichen Excel-Datei steht z.B in A7
"Datum :01.08.2005"
In die Mustertabelle soll nur das Datum in C16
"01.08.2005" in C16
In der ursprünglichen Excel-Datei steht z.B in A16
"Zähler :0001"
In die Mustertabelle soll nur "0001" in C20
Nachdem diese und ähnliche Werte in die neue Mustertabelle übernommen sind, soll diese unter folgendem Namen abgespeichert werden
Inhalt von C20 vom C16 der Mustertabelle also
"0001 vom 01_08_2005.xls"
Danach die nächste alte Tabelle in eine neue Mustertabelle u.s.w
Antwort 4 von Event
Hallo
Jetzt müßte man nur noch wissen wo die Quell-Dateien liegen und welche Namen sie haben. Sind Alle in einem Verzeichnis, in dem nichts anderes drin steht?
Ich geb´s jetzt auf. Siehe Antwort 1.
Gruß
Jetzt müßte man nur noch wissen wo die Quell-Dateien liegen und welche Namen sie haben. Sind Alle in einem Verzeichnis, in dem nichts anderes drin steht?
Zitat:
Nachdem diese und ähnliche Werte in die neue Mustertabelle übernommen sind, soll diese unter folgendem Namen abgespeichert werden
Nachdem diese und ähnliche Werte in die neue Mustertabelle übernommen sind, soll diese unter folgendem Namen abgespeichert werden
Ich geb´s jetzt auf. Siehe Antwort 1.
Gruß
Antwort 5 von Emmis
Nur diese Quell-Dateien liegen alle in C:\Daten und sollten dann in C:\DatenNeu
Antwort 6 von JoeKe
Moin Emmis,
du machst es uns nicht leicht dir zu helfen. Die Fragen von Event zielen auf ein Makro hin das dir die ganze Handarbeit mit kopieren, einfügen und formatieren erspart. Für ein Makro sind allerdings genauere Angaben:
Du siehst für eine sinnvolle Hilfe ist mehr input nötig.
MfG
JöKe
du machst es uns nicht leicht dir zu helfen. Die Fragen von Event zielen auf ein Makro hin das dir die ganze Handarbeit mit kopieren, einfügen und formatieren erspart. Für ein Makro sind allerdings genauere Angaben:
- Welche Bereiche sollen kopiert werden?
Wie heißen die Quelldateien? Sind sie z.B. fortlaufend nummeriert (Alt1, Alt2 usw.)?
Im welchen verzeichnis liegen sie?
usw. usw.
Du siehst für eine sinnvolle Hilfe ist mehr input nötig.
MfG
JöKe
Antwort 7 von Emmis
Die alten Tabellen liegen alle in C.\Daten und sind nicht durchnummeriert, und es befinden sich auch keine anderen Dateien darin.
Es sollen nur 2 Felder von der alten Tabelle kopiert werden. Diese liegen dort als String vor.
In der ursprünglichen Excel-Datei steht in A7
"Datum :01.08.2005"
In die neue Mustertabelle soll aus dem String nur das Datum in C16 kopiert werden. "01.08.2005"
In der ursprünglichen Excel-Datei steht in A16
"Zähler :0001"
In die Mustertabelle soll nur "0001" in C20 kopiert werden
Nach diesen beiden Kopiervorgängen soll die Mustertabelle mit dem Namen
"0001 vom 01_08_2005.xls"
in C:\DatenNeu abgespeichert werden.
Die 0001 steht für den Inhalt von C20 der Mustertabelle, und die 01_08_2005 für das Datum (Inhalt von C16 der Mustertabelle)
Danach soll die nächste Tabelle von C:\Daten geladen werden und die gleichen beiden Felder in eine neue Mustertabelle kopiert und anschließend abgespeicht werden. Die Mustertabelle liegt in c:\Muster\Muster.xls
Die alten Tabellen haben z.B. folgende Namen
0001.xls 44507.xls
MfG Emmis
Es sollen nur 2 Felder von der alten Tabelle kopiert werden. Diese liegen dort als String vor.
In der ursprünglichen Excel-Datei steht in A7
"Datum :01.08.2005"
In die neue Mustertabelle soll aus dem String nur das Datum in C16 kopiert werden. "01.08.2005"
In der ursprünglichen Excel-Datei steht in A16
"Zähler :0001"
In die Mustertabelle soll nur "0001" in C20 kopiert werden
Nach diesen beiden Kopiervorgängen soll die Mustertabelle mit dem Namen
"0001 vom 01_08_2005.xls"
in C:\DatenNeu abgespeichert werden.
Die 0001 steht für den Inhalt von C20 der Mustertabelle, und die 01_08_2005 für das Datum (Inhalt von C16 der Mustertabelle)
Danach soll die nächste Tabelle von C:\Daten geladen werden und die gleichen beiden Felder in eine neue Mustertabelle kopiert und anschließend abgespeicht werden. Die Mustertabelle liegt in c:\Muster\Muster.xls
Die alten Tabellen haben z.B. folgende Namen
0001.xls 44507.xls
MfG Emmis
Antwort 8 von JoeKe
Hallo Emmis,
folgendes Makro macht das von dir gewünschte:
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Select
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ChDir "C:\Daten neu"
ActiveWorkbook.SaveAs Filename:="C:\Daten neu\" & Range("A16") & "_" & Range("A7") & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Next Counter
End With
Application.ScreenUpdating = True
End Sub
Das Makro speicherst du in einem Standart Modul deiner Musterdatei.
MfG
JöKe
folgendes Makro macht das von dir gewünschte:
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Select
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ChDir "C:\Daten neu"
ActiveWorkbook.SaveAs Filename:="C:\Daten neu\" & Range("A16") & "_" & Range("A7") & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Next Counter
End With
Application.ScreenUpdating = True
End Sub
Das Makro speicherst du in einem Standart Modul deiner Musterdatei.
MfG
JöKe
Antwort 9 von Emmis
@ JöKe
Tausend Dank für Deine Mühen.
Das Problem ist nur noch, daß die entnommen Werte nicht in die Mustertabelle eingefügt werden und diese Mustertabelle abgespeichert wird sondern die alte Tabelle wird mit den Änderungen unter neuem Namen abgespeichert.
MfG Emmis
Tausend Dank für Deine Mühen.
Das Problem ist nur noch, daß die entnommen Werte nicht in die Mustertabelle eingefügt werden und diese Mustertabelle abgespeichert wird sondern die alte Tabelle wird mit den Änderungen unter neuem Namen abgespeichert.
MfG Emmis
Antwort 10 von JoeKe
Hallo Emmis,
freut mich das ich dir bis hierhin schon helfen konnte. Haben den Code abgeändert. Probier ihn mal aus.
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\Daten neu\" & Range("A16") & "_" & Range("A7") & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Workbooks.Open Filename:="Muster.xls"
Next Counter
End With
Application.ScreenUpdating = True
End Sub
MfG
JöKe
freut mich das ich dir bis hierhin schon helfen konnte. Haben den Code abgeändert. Probier ihn mal aus.
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\Daten neu\" & Range("A16") & "_" & Range("A7") & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Workbooks.Open Filename:="Muster.xls"
Next Counter
End With
Application.ScreenUpdating = True
End Sub
MfG
JöKe
Antwort 11 von Event
Hallo
@Emmis,
Nun das kommt daher, weil Deine Angaben nicht präzise genug sind.
Hättest Du bereits in Deinem ersten Post oder spätestens im Vierten (A7) die Aufgabenstellung eindeutig erkennbar formuliert, wär´ der Job längst erledigt.
Ich weiß eigentlich immer noch nicht genau was Du mit Mustertabelle
( C:\Muster\Muster.xls oder/und C:\DatenNeu\0001vom 01_08_2005.xls ) meinst.
@Jöke ;-)
WoW Tolle Leistung. Deine Geduld - Bewundernswert!
Wieder was gelernt.
*g*
Gruß
@Emmis,
Nun das kommt daher, weil Deine Angaben nicht präzise genug sind.
Hättest Du bereits in Deinem ersten Post oder spätestens im Vierten (A7) die Aufgabenstellung eindeutig erkennbar formuliert, wär´ der Job längst erledigt.
Ich weiß eigentlich immer noch nicht genau was Du mit Mustertabelle
( C:\Muster\Muster.xls oder/und C:\DatenNeu\0001vom 01_08_2005.xls ) meinst.
@Jöke ;-)
WoW Tolle Leistung. Deine Geduld - Bewundernswert!
Wieder was gelernt.
*g*
Gruß
Antwort 12 von JoeKe
Hi,
@Event,
muss dir rechtgeben mit einwenig mehr input wäre das schneller gegessen gewesen. Und vielen Dank für dein Lob.
BUG-freies WE
JöKe
@Event,
muss dir rechtgeben mit einwenig mehr input wäre das schneller gegessen gewesen. Und vielen Dank für dein Lob.
BUG-freies WE
JöKe
Antwort 13 von Event
Nen kleinen Beitrag möcht´ ich dennoch zusteuern...
Damit´s mit den Unterstrichen im Dateinamen klappt:
Gruß
Damit´s mit den Unterstrichen im Dateinamen klappt:
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu()
´Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\DatenNeu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Workbooks.Open Filename:="Muster.xls"
Next Counter
End With
Application.ScreenUpdating = True
End SubGruß
Antwort 14 von Emmis
Besten Dank an Euch, es funktioniert soweit prima. Ein kleines Problem noch:
Nach dem ersten Durchlauf mit Abspeicherung und Schließung des activeWorkbook ist Schluss. Die Muster.xls wird nicht wieder geladen aber es gibt auch keine Fehlermeldung. Ebenfalls könnte die geöffnete alte Tabelle aus C:\Daten geschlossen werden.
Aber ersteinmal noch ein schönes Wochenende.
MfG Emmis
Nach dem ersten Durchlauf mit Abspeicherung und Schließung des activeWorkbook ist Schluss. Die Muster.xls wird nicht wieder geladen aber es gibt auch keine Fehlermeldung. Ebenfalls könnte die geöffnete alte Tabelle aus C:\Daten geschlossen werden.
Aber ersteinmal noch ein schönes Wochenende.
MfG Emmis
Antwort 15 von JoeKe
Hallo Emmis,
kann es im Moment leider nicht testen, aber ersetze das Ende mal durch folgendes:
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Windows(Daten).Close
Workbooks.Open Filename:="c:\Muster\Muster.xls"
Next Counter
End With
Application.ScreenUpdating = True
End Sub
@Event,
super Idee die für die Unterstriche eine Funktion zubasteln und in den Code einzubauen. ;-)
MfG
JöKe
kann es im Moment leider nicht testen, aber ersetze das Ende mal durch folgendes:
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Windows(Daten).Close
Workbooks.Open Filename:="c:\Muster\Muster.xls"
Next Counter
End With
Application.ScreenUpdating = True
End Sub
@Event,
super Idee die für die Unterstriche eine Funktion zubasteln und in den Code einzubauen. ;-)
MfG
JöKe
Antwort 16 von JoeKe
Moin Emmis,
man sollte nichts unüberlegt abschicken. Deshalb hier nun der korrekte Code:
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\Daten neu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Workbooks.Open Filename:="C:\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
MfG
JöKe
man sollte nichts unüberlegt abschicken. Deshalb hier nun der korrekte Code:
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\Daten neu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Workbooks.Open Filename:="C:\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
MfG
JöKe
Antwort 17 von JoeKe
Nachtrag:
Workbooks.Open Filename:="C:\Muster.xls" hier musst du eventuell den Pfad anpassen.
Wenn deine Muster.xls in einem Ordner Muster abgelegt ist,
wird es bei dir Workbooks.Open Filename:="C:\Muster\Muster.xls" heissen müssen.
Persönlich halte ich es für ungünstig einen Ordner den gleichen Namen zu geben wie der enthaltenen Datei.
MfG
JöKe
Workbooks.Open Filename:="C:\Muster.xls" hier musst du eventuell den Pfad anpassen.
Wenn deine Muster.xls in einem Ordner Muster abgelegt ist,
wird es bei dir Workbooks.Open Filename:="C:\Muster\Muster.xls" heissen müssen.
Persönlich halte ich es für ungünstig einen Ordner den gleichen Namen zu geben wie der enthaltenen Datei.
MfG
JöKe
Antwort 18 von Emmis
Hallo,
das Makro funktioniert wunderbar (grossen Dank an Jöke und Event). Nur nach der 1.Schleife wird das Makro beendet.
Die Musterdatei wird mit den kopierten Werten unter neuem Namen gespeichert und dann geschlossen.Die Datei vom Ordner c:/Daten ist die einzige die noch geöffnet ist, und die Musterdatei wird nicht neu geladen, und auch keine Fehlermeldung. Die Muster.xls habe ich wie empfohlen in C:\Muster.xls.
Ich hoffe das es keine grosse Mühe mehr macht dieses Problem zu lösen.
MfG Emmis
das Makro funktioniert wunderbar (grossen Dank an Jöke und Event). Nur nach der 1.Schleife wird das Makro beendet.
Die Musterdatei wird mit den kopierten Werten unter neuem Namen gespeichert und dann geschlossen.Die Datei vom Ordner c:/Daten ist die einzige die noch geöffnet ist, und die Musterdatei wird nicht neu geladen, und auch keine Fehlermeldung. Die Muster.xls habe ich wie empfohlen in C:\Muster.xls.
Ich hoffe das es keine grosse Mühe mehr macht dieses Problem zu lösen.
MfG Emmis
Antwort 19 von JoeKe
Hi Emmis,
die Dateien/Ordner müssen wie folgt gespeichert sein damit es läuft:
Ordner Daten(mit den zuändernden Dateien) auf C:\
Ordner Daten neu(in den die geänderten Daten rein sollen) auf C:\
Ordener Muster mit der Datei Muster.xls auf C:\ (dann muss diese Zeile so aussehen:
Workbooks.Open Filename:="C:\Muster\Muster.xls")
oder Datei Muster.xls auf C:\ (dann sieht es so aus:Workbooks.Open Filename:="C:\Muster.xls").
Die Pfade musst du schon deinen Gegebenheiten anpassen!
Sobald ein Ordner oder eine Datei in einem anderen Ordner liegt läufts nicht. Es kommt aber auch keine Fehlermeldung. Also mal genau nachsehen wo was ist und den/die Pfad(e) dementsprechend anpassen.
MfG
JöKe
die Dateien/Ordner müssen wie folgt gespeichert sein damit es läuft:
Ordner Daten(mit den zuändernden Dateien) auf C:\
Ordner Daten neu(in den die geänderten Daten rein sollen) auf C:\
Ordener Muster mit der Datei Muster.xls auf C:\ (dann muss diese Zeile so aussehen:
Workbooks.Open Filename:="C:\Muster\Muster.xls")
oder Datei Muster.xls auf C:\ (dann sieht es so aus:Workbooks.Open Filename:="C:\Muster.xls").
Die Pfade musst du schon deinen Gegebenheiten anpassen!
Sobald ein Ordner oder eine Datei in einem anderen Ordner liegt läufts nicht. Es kommt aber auch keine Fehlermeldung. Also mal genau nachsehen wo was ist und den/die Pfad(e) dementsprechend anpassen.
MfG
JöKe
Antwort 20 von JoeKe
Nachtrag:
kopiere meinen letzten Code in deine Muster.xls (mit den angepassten Pfad) und speichere sie einmal ab. Machst du dies nicht wird sie geschlossen ohne das der neue Code gespeichert wurde. Somit steht dieser zum 2. Durchlauf nicht mehr zur Verfügung.
MfG
JöKe
kopiere meinen letzten Code in deine Muster.xls (mit den angepassten Pfad) und speichere sie einmal ab. Machst du dies nicht wird sie geschlossen ohne das der neue Code gespeichert wurde. Somit steht dieser zum 2. Durchlauf nicht mehr zur Verfügung.
MfG
JöKe
Antwort 21 von Emmis
Hallo JöKe,
der Pfad ist richtig eingegeben.
Also C:\Daten für die alten (wird richtig von dort geladen)
C:\DatenNeu für die neuen (wird auch richtig da abgespeichert)
C:\Muster.xls wird auch von dort geladen.
Im Mako sind diese Pfade im Ordnung. Aber nach dem 1.Durchlauf ist das Makro beendet.
MfG Emmis
der Pfad ist richtig eingegeben.
Also C:\Daten für die alten (wird richtig von dort geladen)
C:\DatenNeu für die neuen (wird auch richtig da abgespeichert)
C:\Muster.xls wird auch von dort geladen.
Im Mako sind diese Pfade im Ordnung. Aber nach dem 1.Durchlauf ist das Makro beendet.
MfG Emmis
Antwort 22 von JoeKe
Hi Emmis,
ich gehe immer noch davon aus, dass diese Zeile angepast werden muss:
Workbooks.Open Filename:="C:\Muster.xls" ändere sie mal so ab:
Workbooks.Open Filename:="C:\Muster\Muster.xls")
Schönen Abend
JöKe
ich gehe immer noch davon aus, dass diese Zeile angepast werden muss:
Workbooks.Open Filename:="C:\Muster.xls" ändere sie mal so ab:
Workbooks.Open Filename:="C:\Muster\Muster.xls")
Schönen Abend
JöKe
Antwort 23 von Emmis
Leider keinen Erfolg. Immer noch das gleiche Problem. Wie gesgt, die Pfade stimmen (sind richtig angepaßt), je nach Ort der Muster.xls.
MfG Emmis
MfG Emmis
Antwort 24 von JoeKe
Nabend Emmis,
hab mir das ganze doch noch mal angesehen. Hat sich tatsächlich doch eine Close Anweisung zu viel eingeschlichen.
Hier nun der hoffentlich entgültige Code:
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\DatenNeu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks.Open Filename:="C:\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
MfG
JöKe
hab mir das ganze doch noch mal angesehen. Hat sich tatsächlich doch eine Close Anweisung zu viel eingeschlichen.
Hier nun der hoffentlich entgültige Code:
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
ActiveWorkbook.SaveAs Filename:="C:\DatenNeu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks.Open Filename:="C:\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
MfG
JöKe
Antwort 25 von Emmis
Habe gerade das Makro getestet, und es läuft wunderbar. Ich möchte mich nochmals bei Euch bedanken, und hoffe daß es Euch nicht zu viele Nerven gekostet hat. Ich konnte viel dabei lernen.
MfG Emmis
MfG Emmis
Antwort 26 von Event
Hallo Emmis ;-)
Ich hab´s gleich geahnt, daß das was Längeres wird. Aber Ende Gut alles Gut.
Danke auch für die Rückmeldung.
Gruß
Ich hab´s gleich geahnt, daß das was Längeres wird. Aber Ende Gut alles Gut.
Danke auch für die Rückmeldung.
Gruß
Antwort 27 von JoeKe
Moin Emmis,
kann mich Event nur anschließen. :-))
Gruß JöKe
kann mich Event nur anschließen. :-))
Gruß JöKe
Antwort 28 von Emmis
Hallo,
ich habe noch einmal eine Frage. Ich möchte vor dem Abspeichern noch einmal in die alte Datei zurück und den Wert aus C12 kopieren und in die Muster.xls nach B4 einfügen.
Wie wechsle ich nochmal in die alte Datei.
MfG Emmis
ich habe noch einmal eine Frage. Ich möchte vor dem Abspeichern noch einmal in die alte Datei zurück und den Wert aus C12 kopieren und in die Muster.xls nach B4 einfügen.
Wie wechsle ich nochmal in die alte Datei.
MfG Emmis
Antwort 29 von JoeKe
Hallo Emmis,
füge die fett geschriebenen Zeilen ein:
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
Worksheets(Datei).Range("C12").Copy
Windows("Muster.xls").Activate
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="C:\DatenNeu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks.Open Filename:="C:\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
Konnte das jetzt nicht überprüfen, müsste aber passen.
MfG
JöKe
füge die fett geschriebenen Zeilen ein:
Sub Alt_Neu()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
Range("A7:A16").Copy
Windows("Muster.xls").Activate
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
Worksheets(Datei).Range("C12").Copy
Windows("Muster.xls").Activate
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="C:\DatenNeu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks.Open Filename:="C:\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
Konnte das jetzt nicht überprüfen, müsste aber passen.
MfG
JöKe
Antwort 30 von Emmis
Hallo JöKe
Ich bekomme bei
Worksheets(Datei).Range("C12").Copy
Laufzeitfehler 9 / Index außerhalb der gültigen Bereichs
MfG Emmis
Ich bekomme bei
Worksheets(Datei).Range("C12").Copy
Laufzeitfehler 9 / Index außerhalb der gültigen Bereichs
MfG Emmis
Antwort 31 von JoeKe
Hallo Emmis,
war mein Fehler. Bei "Daten" handelte es sich ja um ein Workbook und nicht um ein Sheet.
Wird deshalb ein wenig umfangreicher. Kann mich aber im Moment nicht darum kümmern. Werde mich, sobald ich etwas habe melden.
Schönes Wochenende
JöKe
war mein Fehler. Bei "Daten" handelte es sich ja um ein Workbook und nicht um ein Sheet.
Wird deshalb ein wenig umfangreicher. Kann mich aber im Moment nicht darum kümmern. Werde mich, sobald ich etwas habe melden.
Schönes Wochenende
JöKe
Antwort 32 von Emmis
Hallo JöKe,
besteht noch die Möglichkeit das Problem zu lösen? Ich will aber keinen nerven.
MfG Emmis
besteht noch die Möglichkeit das Problem zu lösen? Ich will aber keinen nerven.
MfG Emmis
Antwort 33 von JoeKe
Hallo Emmis,
tut mir leid, das es etwas länger gedauert hat.
Hier nun der Code :
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu2()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String, a As Variant, b As Variant, c As Variant, _
NeuerName As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
a = Range("A7")
b = Range("A16")
c = Range("C12")
Windows("Muster.xls").Activate
Range("A7") = a
Range("A16") = b
Range("B4") = c
Range("A7:A16").Select
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
NeuerName = "C:\Daten neu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls"
ActiveWorkbook.SaveAs Filename:=NeuerName, FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks.Open Filename:="C:\Muster\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
Ich denke der macht das so wie du möchtest.
Bei Fragen ruhig nochmal melden.
MfG
JöKe
tut mir leid, das es etwas länger gedauert hat.
Hier nun der Code :
Option Explicit
Private Function Dot2_(wert As String) As String
Dim i%
If Len(wert) > 0 Then
Do Until InStr(1, wert, ".") = 0
i = InStr(1, wert, ".")
If i > 0 Then Mid(wert, i, 1) = "_"
Loop
End If
Dot2_ = wert
End Function
Sub Alt_Neu2()
Application.ScreenUpdating = False
Dim Counter As Integer, Datei As String, a As Variant, b As Variant, c As Variant, _
NeuerName As String
With Application.FileSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\Daten"
.Execute
For Counter = 1 To .FoundFiles.Count
Datei = .FoundFiles(Counter)
Workbooks.Open Filename:=Datei
a = Range("A7")
b = Range("A16")
c = Range("C12")
Windows("Muster.xls").Activate
Range("A7") = a
Range("A16") = b
Range("B4") = c
Range("A7:A16").Select
Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 9), Array(2, 1)), TrailingMinusNumbers:=True
Range("A16").NumberFormat = "0000"
NeuerName = "C:\Daten neu\" & Range("A16") & "_" & Dot2_(Range("A7")) & ".xls"
ActiveWorkbook.SaveAs Filename:=NeuerName, FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks.Open Filename:="C:\Muster\Muster.xls"
Next Counter
End With
Workbooks.Close
Application.ScreenUpdating = True
End Sub
Ich denke der macht das so wie du möchtest.
Bei Fragen ruhig nochmal melden.
MfG
JöKe
Antwort 34 von Emmis
Super Sache JöKe, es funktioniert. Tausend Dank.
MfG Emmis
MfG Emmis
Antwort 35 von Emmis
Guten Morgen,
ich habe nochmal eine Frage zum Abspeichern der neuen Daten. Ist es möglich das Makro nicht in den neuen Dateien mit abzuspeichern?
MfG Emmis
ich habe nochmal eine Frage zum Abspeichern der neuen Daten. Ist es möglich das Makro nicht in den neuen Dateien mit abzuspeichern?
MfG Emmis