Hallo Michael !
Bei der Zeile kommt ein Fehler.
Was soll ich ändern -
chris
Option Explicit
Sub Doppelte_Raus()
Sheets("Ergebnis").Range("A1").CurrentRegion.RemoveDuplicates _
Columns:=Array(1, 2), Header:=xlYes
End Sub
Sub DateiName()
Dim filetoopen As Variant
Dim pfad As String, Ext As String
Dim p&, shMaster&, j&
Dim blaetter$()
pfad = Master.Range("C4").Value
Ext = Master.Range("B3").Value
If pfad = "" Then pfad = ActiveWorkbook.Path
If Dir(pfad & "\*.*") = "" Then pfad = ActiveWorkbook.Path
ChDrive Mid(pfad, 1, 2)
ChDir pfad
filetoopen = Application.GetOpenFilename("Datein als *." & Ext & ", *" & Ext)
If filetoopen False Then
Master.Range("c5").Value = filetoopen
p = InStrRev(filetoopen, "\")
If p > 2 Then Master.Range("c4").Value = Left(filetoopen, p - 1)
Else
Master.Range("C5").Value = "nichts ausgewählt"
End If
Master.Range("C7").Value = ActiveWorkbook.FullName
End Sub
Sub TextLesenUndSchreiben(Blatt$, Datei$, Zeile&, Splitten$)
Dim DNr As Integer, p&, p0&
Dim sIn As String, aIn, aOut()
Dim iIn&, iOut&
DNr = FreeFile
Open Datei For Input As #DNr
sIn = Input(LOF(DNr), DNr)
Close #DNr
aIn = Split(sIn, Splitten) ' #13,#10 oder was auch immer
sIn = "" ' vielleicht?
If UBound(aIn) >= 0 Then
ReDim aOut(1 To UBound(aIn), 1 To 3)
For iIn = 1 To UBound(aIn) ' das 0. wird verworfen
p = InStr(aIn(iIn), " ")
iOut = iOut + 1
If p = 0 Then
aOut(iOut, 1) = "Fehler"
Else
aOut(iOut, 1) = Mid$(aIn(iIn), 1, p - 1)
p0 = InStr(p, aIn(iIn), "")
If p = 0 Then
aOut(iOut, 3) = "Fehler"
Else
p = p + 4
p0 = InStr(p, aIn(iIn), " p Then
aOut(iOut, 3) = Mid$(aIn(iIn), p + 1, p0 - p)
aOut(iOut, 3) = Val(Replace(aOut(iOut, 3), "-", ""))
End If
End If
End If
End If
Next
Sheets(Blatt).Range("A" & Zeile).Resize(iOut, 3) = aOut
End If
End Sub
Sub Aufruf()
Dim shName$, DateiName$
Dim z&
Dim t0 As Single
shName = "Ergebnis"
DateiName = Master.Range("C5").Value
If DateiName = "nichts ausgewählt" Or Dir(DateiName) = "" Then
MsgBox "Fehler bei Datei " & DateiName: Exit Sub
End If
z = Sheets(shName).Range("C" & Rows.Count).End(xlUp).Row + 1
t0 = Timer
Call TextLesenUndSchreiben(shName, DateiName, z, "")
If MsgBox("Eingelesen in " & Timer - t0 & " Sekunden" & vbLf & _
"Doppelte gleich entfernen?", vbYesNo) = vbYes Then Doppelte_Raus
End Sub
