Sub TestAufruf()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rngRow As Range
Dim rngDetail As Range
Dim sName As String, sVorname As String
Dim rngSh1NoteGesamt As Range
Dim rngSh2NoteGesamt As Range
Dim rngSh1Kurs As Range
Dim rngSh2Kurs As Range
Set sh1 = ImportData("Y:\daten1.csv", "Daten1")
Set sh2 = ImportData("Y:\daten2.csv", "Daten2")
For Each rngRow In sh1.UsedRange.Rows
If rngRow.Row > 1 Then
sName = rngRow.Cells(1, 4)
sVorname = rngRow.Cells(1, 5)
Set rngSh1NoteGesamt = rngRow.Cells(1, 9)
If Not rngSh1NoteGesamt.Value = "XX" Then
Set rngSh1Kurs = rngRow.Cells(1, 1)
Set rngDetail = GetDetail(sh2, sVorname, sName)
If rngDetail Is Nothing Then
MsgBox "Details zum Schüler nicht gefunden:" & vbCr & "Vorname: " & sVorname & vbCr & "Name: " & sName, vbInformation
Else
Set rngSh2Kurs = SearchKurs(sh2, rngSh1Kurs.Value)
If Not rngSh2Kurs Is Nothing Then
Set rngSh2NoteGesamt = Intersect(rngSh2Kurs, rngDetail)
rngSh2NoteGesamt.Value = rngSh1NoteGesamt.Value
End If
End If
Else
MsgBox "Fehler: Schüler hat den Kurs " & rngSh1Kurs.Value & " nicht abgeschlossen!", vbInformation
End If
End If
Next
End Sub
Function GetDetail(sh2 As Worksheet, sVorname As String, sName As String) As Range
Dim bFound As Boolean
Dim bInit As Boolean
Dim rngFound As Range
Dim iFoundRow As Integer
With Intersect(sh2.UsedRange, sh2.Range("A:A"))
Set rngFound = sh2.UsedRange
Do While Not bFound And Not rngFound Is Nothing
If Not bInit Then
Set rngFound = .Find(What:=sName)
bInit = True
Else
Set rngFound = rngFound.Offset(1)
Set rngFound = .FindNext(rngFound.Cells(1, 1))
End If
If Not rngFound Is Nothing Then
If iFoundRow < rngFound.Row Then
iFoundRow = rngFound.Row
If rngFound.Offset(0, 1).Value = sVorname Then
bFound = True
End If
Else
Exit Do
End If
End If
Loop
End With
If bFound Then
Set GetDetail = Intersect(sh2.UsedRange, sh2.Rows(rngFound.Row))
Else
Set GetDetail = Nothing
End If
End Function
Function SearchKurs(sh As Worksheet, sKursname As String) As Range
Dim rng As Range
Dim rngFound As Range
Set rng = Intersect(sh.UsedRange, sh.Rows(1))
Set rngFound = rng.Find(What:=sKursname)
If Not rngFound Is Nothing Then
Set SearchKurs = Intersect(sh.UsedRange, sh.Columns(rngFound.Column))
Else
Set SearchKurs = Nothing
End If
End Function
Function ImportData(sFilename As String, queryName As String) As Worksheet
Dim sh As Worksheet
Set sh = ActiveWorkbook.Worksheets.Add
With sh.QueryTables.Add(Connection:="TEXT;" & sFilename, _
Destination:=Range("$A$1"))
.Name = queryName
.FieldNames = True
.RowNumbers = False
.RefreshStyle = xlInsertDeleteCells
.AdjustColumnWidth = True
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Set ImportData = sh
End Function