Hallo
ich hab mal was gebastelt
in ein normales Modul
Sub Nach_ID()
On Error GoTo Fehler
Dim TB1, TB2, i As Double
Dim ZE1 As Integer, ZE2 As Integer, LR1 As Double, LR2 As Double
Dim Best As Boolean
'Application.ScreenUpdating = False
Set TB1 = Sheets("Daten FL")
ZE1 = 7 'ab Zeile
Set TB2 = Sheets("MP FL")
ZE2 = 7 'ab Zeile
With TB2
'Reset
LR2 = WorksheetFunction.Max(ZE2 + 1, .Cells(.Rows.Count, "A").End(xlUp).Row)
.Range(.Rows(ZE2 + 1), .Rows(LR2)).ClearContents
End With
With TB1
'sortieren
LR1 = .Cells(.Rows.Count, "A").End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Sort.SetRange Range("A6:X" & LR1)
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
.Columns(1).NumberFormat = "00000"
'los gehts
For i = ZE1 To LR1
If .Cells(i, 5) <> .Cells(i - 1, 5) Then 'Neue Nr.
ZE2 = ZE2 + 1
TB2.Cells(ZE2, 1) = Format(.Cells(i, 5), "00000") 'Prüflingsnummer
TB2.Cells(ZE2, 2) = .Cells(i, 1) 'KundenName
TB2.Cells(ZE2, 3) = .Cells(i, 3) 'Gebäude
TB2.Cells(ZE2, 4) = .Cells(i, 4) 'Raum
TB2.Cells(ZE2, 5) = .Cells(i, 6) 'Gerät
Best = True
End If
Select Case .Cells(i, 17)
Case "Sichtprüfung für Gerät und Zuleitung"
TB2.Cells(ZE2, 7) = .Cells(i, 24)
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "PE-Widerstand ±200 mA [0,3 Ohm], bis 5 m Zuleitung"
TB2.Cells(ZE2, 8) = .Cells(i, 20) & " " & .Cells(i, 21)
TB2.Cells(ZE2, 9) = .Cells(i, 22) & " " & .Cells(i, 21)
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Isolationsprüfung 500 V [1,0 MOhm]"
TB2.Cells(ZE2, 10) = .Cells(i, 20) & " " & .Cells(i, 21)
TB2.Cells(ZE2, 11) = .Cells(i, 22) & " " & .Cells(i, 21)
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Leitungstest L - N"
TB2.Cells(ZE2, 12) = .Cells(i, 15) ' aus Bemerkung?
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Differenzstrom [3,5 mA]"
TB2.Cells(ZE2, 13) = .Cells(i, 20) & " " & .Cells(i, 21)
TB2.Cells(ZE2, 14) = .Cells(i, 22) & " " & .Cells(i, 21)
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Berührungsstrom [0,5 mA]"
TB2.Cells(ZE2, 15) = .Cells(i, 22)
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Leistungsaufnahme [3,7 kVA], (=230 V*16 A)"
TB2.Cells(ZE2, 16) = .Cells(i, 20) & " " & .Cells(i, 21)
TB2.Cells(ZE2, 17) = .Cells(i, 22) & " " & .Cells(i, 21)
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Laststrom"
'?
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "PE-Widerstand 10 A AC [0,3 Ohm], bis 5 m Zuleitung"
'?
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Ersatzableitstrom [3,5 mA]"
'?
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Isolationsprüfung 500 V [2,0 MOhm]"
'?
Best = Best * (LCase(.Cells(i, 24)) = "ja")
Case "Differenzstrom [0,5 mA]"
'?
Best = Best * (LCase(.Cells(i, 24)) = "ja")
End Select
TB2.Cells(ZE2, 18) = IIf(Best, "OK", "N OK") ' Alle Bestanden?
Next
End With
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD