Datein automatisch öffnen

Sub save() 'strSuchtext = Workbooks("1A.xls").Sheets("Formulare").Range("A2") Workbooks("A1.xls").Sheets("Aufträge").Select Range("Zahl").Select Range("Zahl").Value = Range("Zahl").Value + 1 Selection.Copy Range("A1").Select If Range("A2") <> "" Then Range("A1").End(xlDown).Select ActiveCell.Offset(1, 0).Select Else Range("A2").Select End If ActiveSheet.Paste strSuchtext = Range("I1").Value Workbooks.Open "X:\Reparaturannahme2\A080.xls" Set Db = Workbooks("A1.xls").Sheets("Aufträge") With Workbooks("A080.xls").Sheets("Tabelle1") If Range("A2") <> "" Then '.Range("G12").Copy Db.Range("A1").End(xlDown).Offset(0, 0) .Range("B12").Copy Db.Range("A1").End(xlDown).Offset(0, 2) .Range("B13").Copy Db.Range("A1").End(xlDown).Offset(0, 3) .Range("E14").Copy Db.Range("A1").End(xlDown).Offset(0, 4) .Range("E13").Copy Db.Range("A1").End(xlDown).Offset(0, 5) .Range("B3").Copy Db.Range("A1").End(xlDown).Offset(0, 6) .Range("B7").Copy Db.Range("A1").End(xlDown).Offset(0, 8) .Range("B4").Copy Db.Range("A1").End(xlDown).Offset(0, 9) .Range("B5").Copy Db.Range("A1").End(xlDown).Offset(0, 10) .Range("B6").Copy Db.Range("A1").End(xlDown).Offset(0, 11) .Range("B8").Copy Db.Range("A1").End(xlDown).Offset(0, 12) .Range("B9").Copy Db.Range("A1").End(xlDown).Offset(0, 13) .Range("B14").Copy Db.Range("A1").End(xlDown).Offset(0, 14) .Range("E12").Copy Db.Range("A1").End(xlDown).Offset(0, 15) Else '.Range("G12").Copy Db.Range("A2") .Range("B12").Copy Db.Range("C2") .Range("B13").Copy Db.Range("D2") .Range("E14").Copy Db.Range("E2") .Range("E13").Copy Db.Range("F2") .Range("B3").Copy Db.Range("G2") .Range("B7").Copy Db.Range("I2") .Range("B4").Copy Db.Range("J2") .Range("B5").Copy Db.Range("K2") .Range("B6").Copy Db.Range("L2") .Range("B8").Copy Db.Range("M2") .Range("B9").Copy Db.Range("N2") .Range("B14").Copy Db.Range("O2") .Range("E12").Copy Db.Range("P2") End If End With Workbooks("A1.xls").save Workbooks("A1.xls").Sheets ("Formulare") End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub save() Const verz = "X:\Reparaturannahme2" With Application.FileSearch .NewSearch .LookIn = verz .SearchSubFolders = True .Filename = "*.xls" .Execute End With For y = 1 To Application.FileSearch.FoundFiles.Count Set quelle = Workbooks.Open(Application.FileSearch.FoundFiles(y)) Workbooks("A2.xls").Sheets("Aufträge").Select Range("Zahl").Select Range("Zahl").Value = Range("Zahl").Value + 1 Selection.Copy Range("A1").Select If Range("A2") <> "" Then Range("A1").End(xlDown).Select ActiveCell.Offset(1, 0).Select Else Range("A2").Select End If ActiveSheet.Paste strSuchtext = Range("I1").Value Workbooks.Open "X:\Reparaturannahme2\A080.xls" Set Db = Workbooks("A2.xls").Sheets("Aufträge") With Workbooks("A080.xls").Sheets("Tabelle1") If Range("A2") <> "" Then '.Range("G12").Copy Db.Range("A1").End(xlDown).Offset(0, 0) .Range("B12").Copy Db.Range("A1").End(xlDown).Offset(0, 2) .Range("B13").Copy Db.Range("A1").End(xlDown).Offset(0, 3) .Range("E14").Copy Db.Range("A1").End(xlDown).Offset(0, 4) .Range("E13").Copy Db.Range("A1").End(xlDown).Offset(0, 5) .Range("B3").Copy Db.Range("A1").End(xlDown).Offset(0, 6) .Range("B7").Copy Db.Range("A1").End(xlDown).Offset(0, 8) .Range("B4").Copy Db.Range("A1").End(xlDown).Offset(0, 9) .Range("B5").Copy Db.Range("A1").End(xlDown).Offset(0, 10) .Range("B6").Copy Db.Range("A1").End(xlDown).Offset(0, 11) .Range("B8").Copy Db.Range("A1").End(xlDown).Offset(0, 12) .Range("B9").Copy Db.Range("A1").End(xlDown).Offset(0, 13) .Range("B14").Copy Db.Range("A1").End(xlDown).Offset(0, 14) .Range("E12").Copy Db.Range("A1").End(xlDown).Offset(0, 15) Else '.Range("G12").Copy Db.Range("A2") .Range("B12").Copy Db.Range("C2") .Range("B13").Copy Db.Range("D2") .Range("E14").Copy Db.Range("E2") .Range("E13").Copy Db.Range("F2") .Range("B3").Copy Db.Range("G2") .Range("B7").Copy Db.Range("I2") .Range("B4").Copy Db.Range("J2") .Range("B5").Copy Db.Range("K2") .Range("B6").Copy Db.Range("L2") .Range("B8").Copy Db.Range("M2") .Range("B9").Copy Db.Range("N2") .Range("B14").Copy Db.Range("O2") .Range("E12").Copy Db.Range("P2") End If End With Workbooks("A2.xls").Sheets("Formulare").Select Workbooks("A2.xls").save Application.CutCopyMode = False quelle.Saved = False quelle.Close Next y End Sub

Hallo Zusammen,
ich habe ca. 500-Excel Datein die mit A beginen (z.Bsp: A080, A081...A510). Ich will jetz den Inhalt der Einzelnen Datein entnehmen und in eine Datenbank eintragen. Gibt eine Möglichkeit mit eine While-Schleife die einzelnen Datein zu öffnen, den Inhalt zu kopieren und dann wiered zu schliesen. Alle Datein haben den gleichen Muster.
Bis jetzt habe ich diesen Program entwikelt, aber der Zeigt mir einen Fehler in der Zeile: ".Range("B12").Copy Db.Range("A1").End(xlDown).Offset(0, 2)". Kann mir jemand weiter helfen?


Sub save()
Const verz = "X:\Reparaturannahme2\Reperatur"
With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = True
.Filename = "*.xls"
.Execute
End With
For y = 1 To Application.FileSearch.FoundFiles.Count
Set quelle = Workbooks.Open(Application.FileSearch.FoundFiles(y))
Workbooks.Open "X:\Reparaturannahme2\Reperatur\Data.xls"
Workbooks("Data.xls").Sheets("Tabelle1").Select
Range("Zahl").Select
Range("Zahl").Value = Range("Zahl").Value + 1
Selection.Copy
Range("A1").Select
If Range("A2") <> "" Then
Range("A1").End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Else
Range("A2").Select
End If
ActiveSheet.Paste
Set Db = Workbooks("Data.xls").Sheets("Tabelle1")
With quelle
If Range("A2") <> "" Then
'.Range("G12").Copy Db.Range("A1").End(xlDown).Offset(0, 1)
.Range("B12").Copy Db.Range("A1").End(xlDown).Offset(0, 2)
.Range("B13").Copy Db.Range("A1").End(xlDown).Offset(0, 3)
.Range("E14").Copy Db.Range("A1").End(xlDown).Offset(0, 4)
.Range("E13").Copy Db.Range("A1").End(xlDown).Offset(0, 5)
.Range("B3").Copy Db.Range("A1").End(xlDown).Offset(0, 6)
.Range("B7").Copy Db.Range("A1").End(xlDown).Offset(0, 8)
.Range("B4").Copy Db.Range("A1").End(xlDown).Offset(0, 9)
.Range("B5").Copy Db.Range("A1").End(xlDown).Offset(0, 10)
.Range("B6").Copy Db.Range("A1").End(xlDown).Offset(0, 11)
.Range("B8").Copy Db.Range("A1").End(xlDown).Offset(0, 12)
.Range("B9").Copy Db.Range("A1").End(xlDown).Offset(0, 13)
.Range("B14").Copy Db.Range("A1").End(xlDown).Offset(0, 14)
.Range("E12").Copy Db.Range("A1").End(xlDown).Offset(0, 15)
Else
'.Range("G12").Copy Db.Range("B2")
.Range("B12").Copy Db.Range("C2")
.Range("B13").Copy Db.Range("D2")
.Range("E14").Copy Db.Range("E2")
.Range("E13").Copy Db.Range("F2")
.Range("B3").Copy Db.Range("G2")
.Range("B7").Copy Db.Range("I2")
.Range("B4").Copy Db.Range("J2")
.Range("B5").Copy Db.Range("K2")
.Range("B6").Copy Db.Range("L2")
.Range("B8").Copy Db.Range("M2")
.Range("B9").Copy Db.Range("N2")
.Range("B14").Copy Db.Range("O2")
.Range("E12").Copy Db.Range("P2")
End If
End With
Workbooks("Data.xls").Sheets("Formulare").Select
Workbooks("Data.xls").save
Application.CutCopyMode = False
quelle.Saved = False
quelle.Close
Next y
End Sub

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread