Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1308to1312
1308to1312
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Dateien erzeugen und Werte eintragen

Forumthread: Dateien erzeugen und Werte eintragen

Dateien erzeugen und Werte eintragen
24.04.2013 13:44:54
Andreas
Hallo,
ich möchte mit einem Makro für die Datei "Referenz.xls" neue .xls-Dateien erzeugen, welche als Dateinamen die Bezeichnung der fortlaufenden Zellen aus Spalte A der "Referenz.xls" erhalten und dann jeweils aus der entsprechenden Zeile (von "Referenz.xls") den entsprechenden Wert aus der Spalte D, E und F nehmen und in die jeweils neue Datei in die Zelle A2, B2 und C2 der neuen Dateien eintragen.
Hoffentlich verständlich so.
Danke für Hilfe.

Anzeige

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

Betreff
Datum
Anwender
Anzeige
AW: Dateien erzeugen und Werte eintragen
24.04.2013 14:31:08
UweD
Hallo
Angenommen die Tabelle der "Referenz.xls" sieht so aus:
Tabelle1
 ABC
1DateiWert1Wert2
2Test2B2C2
3Test3B3C3
4Test4B4C4
5Test5B5C5
6Test6B6C6
7Test7B7C7


Dann ginge das z.B. so:

Sub TT()
On Error GoTo Fehler
Dim TB1, WB2, i%
Dim SP%, ZE&, LR&
Set TB1 = ActiveSheet
SP = 1 'Spalte A
ZE = 2 'Zeile 1; 2 wenn Überschrift
LR = TB1.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
Application.ScreenUpdating = False
For i = ZE To LR
TB1.Range("A" & i & ":C" & i).Copy Workbooks.Add.Sheets(1).Range("A" & ZE)
Set WB2 = ActiveWorkbook
With WB2
If ZE > 1 Then TB1.Range("A1:C1").Copy .Sheets(1).Range("A1") 'Überschrift kopieren
.SaveAs Filename:=.Sheets(1).Range("A" & ZE)
.Close
End With
Next
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Anzeige
AW: Dateien erzeugen und Werte eintragen
24.04.2013 14:34:19
UweD
Noch ein Fehler drin
DEF nach ABC

Sub TT()
On Error GoTo Fehler
Dim TB1, WB2, i%
Dim SP%, ZE&, LR&
Set TB1 = ActiveSheet
SP = 1 'Spalte A
ZE = 2 'Zeile 1; 2 wenn Überschrift
LR = TB1.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
Application.ScreenUpdating = False
For i = ZE To LR
TB1.Range("D" & i & ":F" & i).Copy Workbooks.Add.Sheets(1).Range("A" & ZE)
Set WB2 = ActiveWorkbook
With WB2
If ZE > 1 Then TB1.Range("D1:F1").Copy .Sheets(1).Range("A1") 'Überschrift kopieren
.SaveAs Filename:=.Sheets(1).Range("A" & ZE)
.Close
End With
Next
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Anzeige
AW: Dateien erzeugen und Werte eintragen
24.04.2013 17:38:02
andreas
Ich brauche noch einmal Hilfe zu der Aufgabenstellung:
Die Werte, welche aus "Referenz.xls" kopiert werden sollen,
sind eigentlich nicht fortlaufend in Spalte D, E, F enthalten,
sondern in den Spalten D, G, und X.
Zusätzlich sollen die Werte in die neuen Dateien
nicht in fortlaufenden Zellen,
sondern in A2, F2 und K2 eingetragen werden.
Danke!

Anzeige
AW: Dateien erzeugen und Werte eintragen
24.04.2013 14:32:35
Rudi
Hallo,
sowas? 
Sub aaaa()
Dim rngC As Range
Application.ScreenUpdating = False
With Workbooks("Referenzliste.xls").Sheets(1)
For Each rngC In .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
With Workbooks.Add
rngC.Offset(, 3).Resize(, 3).Copy .Sheets(1).Cells(2, 1).Resize(, 3)
.SaveAs rngC
.Close
End With
Next
End With
End Sub

Gruß
Rudi

Anzeige
AW: Dateien erzeugen und Werte eintragen
24.04.2013 17:38:49
andreas
ch brauche noch einmal Hilfe zu der Aufgabenstellung:
Die Werte, welche aus "Referenz.xls" kopiert werden sollen,
sind eigentlich nicht fortlaufend in Spalte D, E, F enthalten,
sondern in den Spalten D, G, und X.
Zusätzlich sollen die Werte in die neuen Dateien
nicht in fortlaufenden Zellen,
sondern in A2, F2 und K2 eingetragen werden.
Danke!

Anzeige
AW: Dateien erzeugen und Werte eintragen
25.04.2013 11:12:36
UweD
Hallo
ich gehe jetzt davon aus, dass die Überschriften aus Zeile 1 mitkopiert werden...

Sub TT()
On Error GoTo Fehler
Dim TB1, i%
Dim LR&
Set TB1 = ActiveSheet
LR = TB1.Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A=1
Application.ScreenUpdating = False
For i = 2 To LR
With Workbooks.Add
TB1.Range("D1").Copy .Sheets(1).Range("A1") 'Überschrift
TB1.Range("D" & i).Copy .Sheets(1).Range("A2") 'Werte
TB1.Range("G1").Copy .Sheets(1).Range("F1")
TB1.Range("G" & i).Copy .Sheets(1).Range("F2")
TB1.Range("X1").Copy .Sheets(1).Range("K1")
TB1.Range("X" & i).Copy .Sheets(1).Range("K2")
.SaveAs Filename:=TB1.Range("A" & i)
.Close
End With
Next
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Gruß UweD

Anzeige
AW: Dateien erzeugen und Werte eintragen
26.04.2013 19:30:04
andreas
Super!
Danke es funktioniert! Klasse!

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige