|
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öhenOption 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 ] |
|
Letzte Aktualisierung: Sonntag, 13. Dezember 2015 |
|