VB 4/6- und VBA-Forum - Beitragsübersicht -
Von aston
E-Mail astonnuesch1@gmail.com
Datum 28. November 2017 um 15:51:10
Frage Hallo

Ich möchte gern ein Skript schrieben, dass ein Excel File
z.B \blabla\bla1_Datum nimmt und dann in einem anderen
Ordner alle Excel Files die dort drin sind überprüft, ob
der Wert in den jeweiligen Spalten B2 (ein Datum) der Files
mit dem Datum im Filenamen, in diesem Fall
\blabla\bla1_Datum übernimmt. Wenn Ja werden bestimmte
Spalten A2, B2, usw. bis J2 in das File \blabla\bla1_Datum
übertragen. Und das macht es mit jedem File im diesem
Ordner. Am Schluss speichert es alles und nimmt dann das
nächste File \blabla\bla2_Datum und geht wieder in diesem
Ordner Files durch und macht nochmal das gleiche und wird
dann automatisch gespeichert. Und das Skript soll das
solange mach bis es kein File mehr findet der
\blabla\bla(hier kommt dann eine Nummer) _Datum heisst. Das
heisst bei jedem Durchlauf soll das Datum und die Nummer im
Filename um eins erhört werden bis kein File mehr findet
das so heisst.

Das ist was ich bis jetzt habe und habe mir gedacht das
Ganze in eine Schleife zupacken und die Variable num und
das Datum bei jedem durchlauf um eins zu erhöhen
Option Explicit
Option Compare Text

Const Folder = "D:\Test_Umgebung\Orders_xlsx"

Public Sub test2()

Dim Datei As String
Dim Verzeichnis As String
Dim SaveDummy As Variant
Dim Datum As Date
Dim num As String
Dim Filename As String
Dim aktDate As Date
Dim Wkb As Workbook, Fso As Object, file As Object, Zeile
As Long
Dim Wkb2 As Workbook


aktDate = "17.10.2017"
num = "1"


With Application
.ScreenUpdating = False 'Bildschirmaktualisierung
aus
.AskToUpdateLinks = False 'Verknüpfung (Name aus
Übersicht) ohne Abfrage aktualisieren
.DisplayAlerts = False 'Fehlermeldung "Verknüpfung
kann nicht..." unterdrücken
End With

Set Fso = CreateObject("Scripting.FileSystemObject")
'Dateisystem-Operationen

Workbooks.Open
"D:\Test_Umgebung\xls_File_pro_Migrationstag\UC50_SAFE_LAUR
A_" & aktDate & "--" & num & ".xlsx"
Set Wkb2 =
Workbooks.Open("D:\Test_Umgebung\xls_File_pro_Migrationstag
\UC50_SAFE_LAURA_" & aktDate & "--" & num & ".xlsx")
For Each file In Fso.GetFolder(Folder).Files 'Alle
_orders.xlsx-Dateien einlesen und eintragen
If Fso.GetExtensionName(file.Name) Like "xlsx" And
Fso.GetBaseName(file.Name) Like "*orders*" Then
Set Wkb = GetObject(file.Path)
With Wkb.Sheets(1) 'Werte mit Zahlenformat
werden erst geptrüft
'Wenn Feld B2 aus dem File orders.xls =
'das Datum das beim neuen File eingeben
wurde dann coppy Restliche Felder
If Wkb.Sheets(1).Range("B2").Value =
aktDate Then

'### Ermitteln der ersten freien
Zelle In Spalte A ###
Zeile = Cells(Rows.Count,
1).End(xlUp).Row + 1
'### Wenn erste freie Zeile kleiner
3 dann In 3 beginnen ###
If Zeile < 3 Then Zeile = 3
.Range("A2").Copy: Cells(Zeile,
"A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("B2").Copy: Cells(Zeile,
"B").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("C2").Copy: Cells(Zeile,
"C").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("D2").Copy: Cells(Zeile,
"D").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("E2").Copy: Cells(Zeile,
"E").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("F2").Copy: Cells(Zeile,
"F").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("G2").Copy: Cells(Zeile,
"G").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("H2").Copy: Cells(Zeile,
"H").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("I2").Copy: Cells(Zeile,
"I").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("J2").Copy: Cells(Zeile,
"J").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
End With
Wkb.Close False
End If
Next

With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.DisplayAlerts = True
End With
Wkb2.Save
Workbooks.Close
End Sub
[ Antwort schreiben | Zurück zum VB 4/6- und VBA-Forum | Forum-Hilfe ]
Antworten
E10: Automatisierungs Skript das ebenfalls automatisch all 5h aut - aston 28. November 2017 um 15:51:10

Ihre Antwort
(Nick-)Name   Wichtige Informationen zur Namensangabe
E-Mail (opt.)  Wichtige Informationen zur Angabe einer eMail-Adresse
Thema   Wichtige Informationen zur Angabe eines Themas
Betrifft (IDE)  Excel 2010 (VBA 6)
Ihre Antwort
Smilies
Mehr...
FettKursivUnterstrichen   Übersicht der Tipp-KürzelÜbersicht der Projekt-KürzelÜbersicht der Bücher-Kürzel 
Homepage
Titel
Root-Smilies              
             
             
[ Zurück zum VB 4/6- und VBA-Forum | Forum-Archiv | Forum-Hilfe | Chat ]

Zum Seitenanfang

Startseite | VB-/VBA-Tipps | Projekte | Tutorials | API-Referenz | Komponenten | Bücherecke | Gewinnspiele | VB.Net | .Net-Forum | DirectX | DirectX-Forum | Chat | Ausschreibungen | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 13. Dezember 2015