Zellen in Textdatei schreiben/lesen, Werte übern.
22.05.2013 09:28:18
Ulrich
Habe versucht in den letzten Tagen mein Wissen mit VBA zu füllen.
Leider komme ich bei meinen Problemen nicht weiter, hoffe es kann mir jemand helfen.
Folgende Funktionen habe ich eingebaut:
Beim öffnen des Dokument folgt eine Abfrage ob die Daten abgeglichen werden sollen.
Wird die Abfrage mit "Ja" beantwortet, werden alle Zellen aus Spalte A(1) in eine Textdatei geschrieben. Als nächster werden die Log-Datein ausgelesen.
Gibt es eine Möglichkeit doppelte Daten nicht zu übernehmen?
Dannach sollen alle Zellen die ein X enthalten kopiert und als Wert eingefügt werden.
Leider werden die Werte angefügt, möchte diese aber gerne ersetzen.
Vielleicht gibt es auch eine andere Möglichkeit, den Wert einer Formel zu übernehmen.
Vielen Dank im Vorraus =)
Sub workbook_open()
a = MsgBox("Daten abgleichen?", vbYesNo + vbQuestion, "Abfrage")
If a = vbNo Then Exit
Sub Else
' schreibt alle Zellen aus Spalte A(1) in eine Textdatei
Dim intFF As Integer
Dim iZeile As Integer
Dim strDatei As String
Dim strTemp As String
strDatei = "C:\Test.txt"
intFF = FreeFile
iZeile = 1 ' Variable für Zeilennummer
Open strDatei For Output As #intFF ' Öffnet oder erstellt Textdatei zum _
hineinschreiben
Do Until Cells(iZeile, 1).Value = "" ' Schleife: Laufe solange, bis Zelle leer ist
strTemp = Cells(iZeile, 1) ' Zellwert an Zwischenspeicher übergeben
Print #intFF, strTemp ' Zwischenspeicher in TXTDatei schreiben
iZeile = iZeile + 1 ' Zeilenzähler erhöhen
Loop ' zurück zum Schleifenbeginn
Close #intFF ' schließt die Textdatei
'Auslesen der Log-Datei
Dim strPfad As String
Dim FSO As Object
Dim file
Dim lngLR As Long
strPfad = "C:\log\" 'Verzeichnis
Set FSO = CreateObject("scripting.filesystemobject")
For Each file In FSO.getfolder(strPfad).Files
strFileName = file.Name
Sheets("Uebersicht").Select
strDestination = "E" & Cells(Rows.Count, 5).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strPfad & strFileName, Destination:=Range(strDestination))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
Sheets("Tabelle1").Select
'Zeile kopieren wenn Wert in Zelle
Dim i As Long, suchCol As Long
Dim strSearch As String
Dim srcWks As Worksheet, tarWks As Worksheet
'Tabellennamen anpassen
'srcWks wo gesucht werden soll
Set srcWks = Worksheets("Tabelle1")
'tarWks wo hinkopiert werden soll
Set tarWks = Worksheets("Tabelle1")
'6 = Spalte F
suchCol = 6
'strSearch = was gesucht werden soll
strSearch = "X"
With srcWks
For i = 1 To .Cells(Rows.Count, suchCol).End(xlUp).Row
If .Cells(i, suchCol).Text = strSearch Then
Rows(i).Copy Destination:=tarWks.Cells(tarWks.Cells(Rows.Count, 1).End(xlUp). _
Row + 1, 1)
End If
Next i
End With
End Sub
Anzeige