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

Makros verbinden

Makros verbinden
Horst
Hallo Excel-Freaks!
Ich würde gern die Funktionalität folgender zwei VBA-Proezuduren in einem Makro verbinden.
Das erste Makro filtert mittels Autofilter bestimmte Werte, das zweite wandelt in Abhängigkeit vom Systemdatum die .xls in Textdateien um. Es soll nun ein Makro entstehen, dass zunächst die gewünschten Zeilen mittels Autofilter selektiert und danach die gewünschten .txt-Dateien generiert.
Wie gehe ich am besten vor?

Sub Selection_one()
Dim wbText As Workbook, wbAktiv As Workbook, vFilename
Set wbAktiv = ActiveWorkbook
Cells.AutoFilter Field:=131, Criteria1:="1"
Range("A1:DY65536").Copy 'es werden keine verknüpfungen kopiert
Set wbText = Workbooks.Add(Template:=xlWBATWorksheet)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Dokumente und Einstellungen\User\Desktop\system\update\FilteredBase_one.xls",  _
FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End Sub


Sub PatternFiltering_one()
Dim objWb As Workbook
Dim strPath1 As String, strFile As String, strTxtFile As String, strTmp As String, strSep  _
As String
Dim intIndex As Integer, lngRow As Long, lngLastCol As Long, lngN As Long, lngM As Long
Dim arrVal As Variant
On Error GoTo ErrExit
GMS
strPath1 = "C:\Dokumente und Einstellungen\User\Desktop\system\update" 'Pfad
If Right(strPath1, 1)  "\" Then strPath1 = strPath1 & "\"
strFile = Dir(strPath1 & "*.xls")
Do While strFile  ""
If isOpen(strFile) Then
Set objWb = Workbooks(strFile)
Else
Set objWb = Workbooks.Open(strPath1 & strFile)
End If
intIndex = intIndex + 1
Application.Calculate
objWb.Close True
strFile = Dir
Loop
'Textdateien
strSep = vbTab 'Trennzeichen für txt-Dateien
strFile = strPath1 & "database.xls"
Set objWb = Workbooks.Open(strFile)
With objWb.Sheets("results") 'Tabellenname!
lngLastCol = .Columns("DY").Column 'letzte auszulesende Spalte
lngRow = Application.Match(CLng(Date), .Columns("DY"))
arrVal = .Range(.Cells(1, 1), .Cells(lngRow, lngLastCol))
strTxtFile = strPath1 & "train_one.txt"
Open strTxtFile For Output As #1
For lngN = 1 To lngRow
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & Replace(arrVal(lngN, lngM), ",", ".") & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
Print #1, strTmp
Next
Close #1
strTxtFile = strPath1 & "retrain_one.txt"
Open strTxtFile For Output As #1
For lngN = 4000 To lngRow
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & Replace(arrVal(lngN, lngM), ",", ".") & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
Print #1, strTmp
Next
Close #1
arrVal = .Range(.Cells(lngRow + 1, 1), .Cells(lngRow + 1, lngLastCol))
strTmp = ""
For lngM = 1 To lngLastCol
strTmp = strTmp & Replace(arrVal(1, lngM), ",", ".") & strSep
Next
strTmp = Left(strTmp, Len(strTmp) - Len(strSep))
strTxtFile = strPath1 & "test_one.txt"
Open strTxtFile For Output As #1
Print #1, strTmp
Close #1
End With
objWb.Close False
ErrExit:
If Err.Number  0 Then
End If
GMS True
Set objWb = Nothing
End Sub

Besten Dank vorab!
Horst

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Makros verbinden
14.05.2011 06:29:21
Frank
Hallo Horst!
Ich glaube es geht so?
Sub Selection_one()
Dim wbText As Workbook, wbAktiv As Workbook, vFilename
Set wbAktiv = ActiveWorkbook
Cells.AutoFilter Field:=131, Criteria1:="1"
Range("A1:DY65536").Copy 'es werden keine verknüpfungen kopiert
Set wbText = Workbooks.Add(Template:=xlWBATWorksheet)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Dokumente und Einstellungen\User\Desktop\system\update\FilteredBase_one.xls",  _
FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
PatternFiltering_one
End Sub
Konnte ich helfen?
Gruß Frank H.!!!
Anzeige
AW: Makros verbinden
14.05.2011 12:55:39
Horst
Hallo,
danke für die Bemühungen, funktioniert allerdings noch nicht ganz. Vielleicht kann Franz "fcs" sich mal kurz melden, der hat mir damals mit einem Teil des Codes geholfen. Wäre super.
Danke!
Horst
AW: Makros verbinden
15.05.2011 10:52:33
Tino
Hallo,
ohne den Code u. die Tabelle nachzubauen,
sehe ich jetzt keinen Grund warum es nicht funktionieren sollte.
Wenn beide Makros einzeln aufgerufen funktionieren,
sollte es auch gehen wenn Du am Ende von
Selection_one die PatternFiltering_one aufrufst.
Entweder einfach mit
PatternFiltering_one
Oder mit
Call PatternFiltering_one
Gruß Tino
Anzeige
AW: Makros verbinden
15.05.2011 17:46:35
Horst
Hallo Tino,
ein kleines Problem ergibt sich in der Zeile "lngRow = Application.Match(CLng(Date), .Columns("DY"))", wo das Systemdatum gesucht wird. Bedingt durch die 'autogefilterte' Datengrundlage kann es vorkommen, dass es genau dieses Datum nicht gibt, sondern stets Datumswerte kleiner Systemdatum.
Wie gebe ich an, dass vom Datum, dass am nähesten am Systemdatum liegt (der letzte Eintrag in Spalte DY kleiner Systemdatum) 50 Zeilen zurück in die test.txt kopiert werden, der Rest in die train.txt
Gruß, Horst
AW: Makros verbinden
15.05.2011 18:56:44
Tino
Hallo,
die nächst kleinere könnte man so rausfinden, wenn die Daten sortiert sind.
lngRow = Application.match(clng(date),.columns("DY"),1)
Wenn sie nicht sortiert sind, evtl. so (gibt die Zeile zurück)
Sub Beispiel()
Dim lngRow&, MaxRow&, strAdress$

With Tabelle1
    MaxRow = .Cells(.Rows.Count, 130).End(xlUp).Row
    strAdress = .Range("DZ1:DZ" & MaxRow).Address(ReferenceStyle:=xlR1C1, External:=True)
End With

lngRow = ExecuteExcel4Macro("SUMPRODUCT(MAX((" & strAdress & "<=TODAY())*(" & strAdress & ">0)*ROW(" & strAdress & ")))")


End Sub
Gruß Tino
Anzeige
wenn Du es nicht hinbekommst...
15.05.2011 19:03:27
Tino
Hallo,
, lade mal eine Beispieldatei hoch.
Erkläre was, wann und warum in eine Textdatei gespeichert werden soll.
Kann aber nicht versprechen ob ich da heute noch dran gehe.
Gruß Tino
AW: wenn Du es nicht hinbekommst...
16.05.2011 00:12:11
Horst
Hallo Tino,
habe dir anbei eine Beispieldatei hochgeladen. Im Prinzip geht es um folgende Problematik: Eine Datei namens "database.xls" enthält Verknüpfungen zu einer von einem externen Programm generierten .xls.
Diese Datei habe ich hochgeladen (hier verkürzt und ohne Verknüpfungen), siehe:
https://www.herber.de/bbs/user/74849.zip
Die angedachte VBA-Prozedur soll nun zunächst in der "database.xls" alle vorhandenen Verknüpfungen aktualisieren,
danach in Spalte "H" einen Autofilter setzen und vom Arbeitsblatt nur jene Zeilen extrahieren, in denen in "H" der Wert "1" steht und darauf aufbauend
in Spalte "G" das dem Systemdatum am nächsten kommende (kleinere) Datum suchen (Datumswerte sind hier immer in chronologischer Reihenfolge gelistet, können allerdings nicht nur ganze Tage, sondern auch Stunden oder Minuten umfassen) und von diesem ausgehend
den letzten Eintrag in eine "test.txt", die letzten 50 Einträge davor in eine "retrain.txt" und alle zeitlich weiter zurückliegenden Einträge in eine "train.txt" schreiben.
Abschließend soll der in "database.xls" gesetzte Autofilter wieder deaktiviert und alle geöffneten .xls-Dateien ohne zu speichern geschlossen werden.
Wäre genial, wenn du mir einen durchgehenden VBA-Code dazu senden könntest.
Allerbesten Dank vorab!
Horst
Anzeige
kannst mal testen, ...
16.05.2011 17:02:05
Tino
Hallo,
Zip- File auspacken und in der Test_File.xls auf den Button klicken.
Zurzeit (zum Testen) ist der Ordner wo sich die Dateien befinden im Ordner der Excel- Dateien,
diese Pfadangaben müsstest Du später auf Deine Ordner anpassen.
Zudem werden die Text- Dateien zurzeit gelöscht wenn diese vorhanden sind,
der entsprechende Code ist kommentiert, evtl. löschen.
https://www.herber.de/bbs/user/74863.zip
Gruß Tino
noch eine Variante...
16.05.2011 19:42:51
Tino
Hallo,
hier noch eine Variante mit Hilfer Windows Zwischenablage.
Vorteil, Text wird so geschrieben wie dargestellt ohne ihn zu Formatieren.
Der Rest ist wie zuvor schon geschrieben.
https://www.herber.de/bbs/user/74866.zip
Gruß Tino
Anzeige
AW: noch eine Variante...
17.05.2011 00:32:39
Horst
Hallo Tino,
was soll ich sagen ... hab's ausgiebig getestet ... einfach Weltklasse die beiden Varianten, funktionieren bestens.
Abschließend noch eine Sache: Wie kann berücksichtigt werden, dass sich in der "database.xls" vorhandene Verknüpfungen zu externen Quellen (externen .xls) automatisch aktualisieren? Ist dies mit der Zeile "iCalc = oApp.Calculation" bereits abgetan?
Muss die "Test_File.xls" (welche das Makro enthält) und die zu verarbeitende "database.xls" immer im gleichen Ordner sein? Sofern die "database in einem anderen Speicherordner liegt, müsste ich dann die Zeile
sPath$ = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
anpassen?
Allerbesten Dank und schöne Grüße nach Waldmohr!
Horst
Anzeige
AW: noch eine Variante...
17.05.2011 16:26:00
Tino
Hallo,
die Aktualisierung der Links wird durch den zweiten Parameter beim öffnen angegeben.
Diesen Parameter habe ich zwar bis heute nicht richtig verstanden,
bei mir funktioniert er aber mit dem Wert True.
Schau mal in die Hilfe unter "Workbooks.Open",
da steht was von 0, 1, 2 o. 3 evtl. dies einmal durchtesten.
Set oWB_Ex = oApp.Workbooks.Open(File_XLX, True, True)
Zu der Pfadangabe für die database.xls, müsstest Du den Pfad bei
File_XLX = sPath & "database.xls" 'evtl. Pfad anpassen
Anpassen, z. Bsp. so
File_XLX = "C:\Ordner\database.xls"
Besser wäre wenn Du nach der Zeile
With .Sheets("results")
noch diese mit einfügst, damit nochmal alles durchgerechnet wird.
.Calculate
Gruß Tino
Anzeige
AW: noch eine Variante...
17.05.2011 23:03:18
Horst
Hallo Tino,
... es klappt alles perfekt.
Du bist einfach der Beste hier im Forum! Wenn ich wiedermal was brauche, melde ich mich.
Danke nochmal für deine Bemühungen!
Gruß, Horst

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige