Hallo Reinhard,
aber sie steht immer in H ? Oder kann sie auch pro Zeile in
verschiedenen Spalten stehen?
sie steht immer in der selben Zeile aber in verschiedenen Spalten, je nach Platzangebot. 
Als das Dokument gebaut wurde, hat Niemand an automatisieren gedacht.
Wie erkenne ich denn die Personalnummer in einem Zelltext?
Es steht ‚Pers.Nr.‘ davor.
Ich gehe jetzt die 12 Spalten (Zeile ist immer gleich) in
einer Schleife durch und suche mit Left() … Geht.
Also steht die Personalnummer doch immer links?
Ich hab das nicht so ganz kapiert -(
Egal, ist schon ausgeliefert.
Wenn ich Glück habe, sehe ich das Dokument nie wieder, ich schicke nur monatlich eine Mail, die Daten als Futter dafür enthält.
Nun muss das Dokument eben doch erst unter neuem Namen gespeichert werden, geschlossen und neu geöffnet. Das ist immer noch einfacher, als rund 1500 Zeilen abtippen.
Gruß Rainer
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Sub Workbook\_Open()
Dim PNR As String, Datei As String, Txt As String
Dim MoString As String, Monat As String, Jahr As String
Dim pos As Long, i As Integer, n As Integer, c As Integer
Dim po(3), sh As Long
Txt = Trim(Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 23))
pos = InStr(Txt, " ")
MoString = Trim(Left(Txt, pos))
Select Case MoString
Case "Januar"
Monat = "01"
Case "Februar"
Monat = "02"
Case "März"
Monat = "03"
Case "April"
Monat = "04"
Case "Mai"
Monat = "05"
Case "Juni"
Monat = "06"
Case "Juli"
Monat = "07"
Case "August"
Monat = "08"
Case "September"
Monat = "09"
Case "Oktober"
Monat = "10"
Case "Novenber"
Monat = "11"
Case "Dezember"
Monat = "12"
Case Else
MsgBox "Tippfehler bei Monat!", vbCritical
Exit Sub
End Select
Txt = Trim(Right(Txt, Len(Txt) - pos))
Jahr = Left(Txt, 4)
If Not IsNumeric(Jahr) Then
MsgBox "Das Jahr wurde nicht an der erwarteten Stelle im Dateinamen gefunden! " + Chr(13) + "Es wird der Name: 'Prämienlohneinzelabrechnung Monat Jahr für Monat Jahr' erwartet!", vbCritical
End If
Datei = ThisWorkbook.Path + "\" + "SBS-Akkord-" + Jahr + "-" + Monat + ".txt"
For sh = 1 To ThisWorkbook.Sheets.Count
ThisWorkbook.Sheets(sh).Activate
ThisWorkbook.Sheets(sh).Range("B5") = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
For c = 1 To 14
If Left(Cells(7, c), 7) = "Pers.Nr" Then
PNR = Right(Cells(7, c), 7)
End If
Next
po(1) = 3
po(2) = 7
po(3) = 5
Cells(11, 3) = 0
Cells(11, 5) = 0
Cells(11, 7) = 0
n = 12
While Cells(n, 1) = 494
n = n + 1
Wend
For i = n - 1 To 12 Step -1
Rows(i).Delete
Next
n = 0
If PathFileExists(Datei) Then
Open Datei For Input As #1
While EOF(1) = False
Line Input #1, Txt
If Txt = PNR Then
Line Input #1, Txt
If Txt = "2" Then
If n \> 0 Then
ThisWorkbook.Sheets(sh).Range("A11", "M11").Copy
ThisWorkbook.Sheets(sh).Rows(n + 11).Insert xlShiftDown
ThisWorkbook.Sheets(sh).Range("A" + CStr(n + 11)).Select
ThisWorkbook.Sheets(sh).Paste
End If
Cells(11 + n, po(1)) = Txt
Line Input #1, Txt
Cells(11 + n, po(2)) = Txt
Line Input #1, Txt
Cells(11 + n, po(3)) = Txt
n = n + 1
Else
Line Input #1, Txt
Line Input #1, Txt
End If
Else
For i = 1 To 3
Line Input #1, Txt
Next
End If
Wend
Close #1
If n \> 0 Then
Txt = "=SUM(H11:H" + CStr(n + 10) + ")"
ThisWorkbook.Sheets(sh).Range("H" + CStr(n + 12)).Formula = Txt
Txt = Replace(Txt, "H", "F")
ThisWorkbook.Sheets(sh).Range("F" + CStr(n + 12)).Formula = Txt
Txt = Replace(Txt, "F", "M")
ThisWorkbook.Sheets(sh).Range("M" + CStr(n + 12)).Formula = Txt
End If
ThisWorkbook.Sheets(sh).Range("O1").Select
ThisWorkbook.Sheets(sh).Range("O1").Copy
End If
Next
End Sub
Kann nicht auch mal etwas einfach sein?