Automatisiertes erstellen von Dateien

Hallo zusammen!
Zu sagen, dass ich ein kleines Problem habe, wäre nicht ganz richtig, ich habe ein großes...
So sieht es bei mir aus:
In einer Datei (Sichtprüfung.xls) werden folgende Felder als Kopf ausgefüllt:
Sachnummer, Auftragsnummer, Stückzahl, Seriennummer von / bis, Name
Es gibt nun vier Spalten, die folgende Bezeichnungen haben:
Seriennummer, geprüft (j / n), Name, Datum, diese werden bis auf das Datum von Hand ausgefüllt.
In Abhängigkeit zu dieser Datei gibt es eine weitere (ICT.xls), in der der Kopf übernommen wird (='Z:\Protokoll\Sachnummer\Auftragsnummer\[Sichtprüfung.xls]Sicht'!$F$1 für die entsprechenden Zellen). Hier gibt es nun zusätzlich die Spalte Sichtprüfung, die die Daten aus der Datei Sichtprüfung.xls abfragt (=WENN('='Z:\Protokoll\Sachnummer\Auftragsnummer \[Sichtprüfung.xls]sicht'!$C$7="j";"JA";"nein)".
Meine Frage ist nun, ob ich das Erstellen der zweiten Datei (also ICT.xls) per Makro o.ä. irgendwie automatisieren kann. Die Anzahl der Zeilen ist je nach Auftrag sehr unterschiedlich, mindestens 10, maximal 1600, sie sollten also aus der ausgefüllten Datei (Sichtprüfung.xls) übernommen werden. Ich meine dies in der Form, wenn ich die erste Tabelle fertig habe und diese speichere, ein Makro die Datei ICT.xls erstellt.
Ich würde mich über jegliche Hilfestellung mehr als freuen...
Vielen Dank!
Frank

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Erzeuge_ICT() Dim isz%, i% Dim sPath As String, sFile As String ' Der Backup-Pfad = der Pfad der aktuellen ArbMappe sPath = ActiveWorkbook.Path Workbooks.Add For i = 1 To 5 Cells(1, i) = Workbooks("Sichtprüfung.xls").Sheets(1).Cells(1, i) Next i ActiveWorkbook.SaveAs Filename:=sPath & "\ICT.xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False End Sub

Sub Erzeuge_ICT() Dim i% Dim rZiel As Worksheet Dim sPath As String, sFile As String Workbooks("Sichtprüfung.xls").Activate ' Der Backup-Pfad = der Pfad der aktuellen ArbMappe sPath = ActiveWorkbook.Path ' eine neue Mappe anlegen Workbooks.Add ' und mit entspr. Namen abspeichern ActiveWorkbook.SaveAs Filename:=sPath & "\ICT_1.xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ' das Blatt bekommt einen Namen ActiveWorkbook.Sheets(1).Name = "sh1" ' und wird als Ziel bestimmt Set rZiel = ActiveWorkbook.Sheets("sh1") ' die Zellen A1 bis E4 werden auf einen Schlag rüber kopiert Workbooks("Sichtprüfung.xls").Sheets(1).Range("A1:E4"). _ Copy rZiel.Range("A1") ' die Zelle "A6" wird gefüllt rZiel.Cells(6, 1) = "Sichtprüfung durchgeführt von:" ' Die Überschriften holen For i = 1 To 4 rZiel.Cells(9, i) = Workbooks("Sichtprüfung.xls"). _ Sheets(1).Cells(5, i) Next i rZiel.Cells(9, 6) = "Sichtprüfung erfolgt?" ' die 3 Namen reinholen For i = 5 To 7 rZiel.Cells(i, 3) = Workbooks("Sichtprüfung.xls"). _ Sheets(1).Cells(i - 3, 8) Next i ' Rest ggf. später End Sub

Hallo Frank,
Fernsehen war mir zu langweilig - so kommst du auch noch zum
zweiten Teil der Aufgabe. Hier nochmal der ganze Code:
So hast du schon mal alle relevanten Daten in der neuen Datei.
Vielleicht musst du an der Optik noch feilen (z.B. mit Makrorecorder
aufzeichnen und dann in VBA-Code einbauen...
Option Explicit


Sub Erzeuge_ICT()
Dim i%, j%, iZlGes%
Dim rZiel As Worksheet
Dim sPath As String, sFile As String
Workbooks("Sichtprüfung.xls").Activate
Set rZiel = Workbooks("ICT_1.xls").Sheets("sh1")
' die letzte Zeile bestimmen
iZlGes = Cells(15000, 1).End(xlUp).Row
'  Der Backup-Pfad = der Pfad der aktuellen ArbMappe
sPath = ActiveWorkbook.Path
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=sPath & "\ICT_1.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Sheets(1).Name = "sh1"
Set rZiel = ActiveWorkbook.Sheets("sh1")
Workbooks("Sichtprüfung.xls").Sheets(1).Range("A1:E4"). _
Copy rZiel.Range("A1")
rZiel.Cells(6, 1) = "Sichtprüfung durchgeführt von:"
' Die Überschriften holen
For i = 1 To 4
rZiel.Cells(9, i) = Workbooks("Sichtprüfung.xls"). _
Sheets(1).Cells(5, i)
Next i
rZiel.Cells(9, 6) = "Sichtprüfung erfolgt?"
' die 3 Namen reinholen
For i = 5 To 7
rZiel.Cells(i, 3) = Workbooks("Sichtprüfung.xls"). _
Sheets(1).Cells(i - 3, 8)
Next i
For i = 10 To iZlGes + 4
If Cells(i - 4, 1) = "" Then Exit Sub
For j = 1 To 4
Select Case j
Case 1
rZiel.Cells(i, j).Value = Cells(i - 4, j).Value
Case 2
If Cells(i - 4, j) = "j" Then
rZiel.Cells(i, j + 4).Value = "Ja"
Else
rZiel.Cells(i, j + 4).Value = "nein"
End If
Case 4
rZiel.Cells(i, j).Value = Cells(i - 4, j).Value
End Select
Next j
Next i
End Sub

Viel Spaß und Erfolg mit den weiteren Versuchen wünscht dir
Eberhard

Beliebteste Forumthreads (12 Monate)

Automatisiertes erstellen von Dateien

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread