AW: Makroerweiterung gesucht
17.12.2008 12:24:00
fcs
Hallo Anja,
die Verwendung von verbundenen Zellen macht es nicht unbedingt leichter, aber ich hab es hinbekommen.
Hier die angepasste Prozedur.
Für das Suchen des Tippernamens hab ich die For-Each-Schleife durch die Find-Methode ersetzt.
Erhöht die Geschwindigkeit.
Gruß
Franz
Sub GetData()
Dim wkb As Workbook, wks As Worksheet
Dim lngDayPlr As Long, lngDayRes As Long
Dim vSpieltag As Variant, rngSpieltag As Range
Dim rng As Range, sName As String, sMsg As String
On Error GoTo Fehler 'Diese Zeile ggf. deaktivieren, um Fehler verursachende Zeile _
leichter zu finden
Application.ScreenUpdating = False
For Each wks In ThisWorkbook.Worksheets 'durchlaufe alle Tabellenblätter
If wks.CodeName "Start" Then
'Spieltag in Result-Tabelle in Zelle C2
lngDayRes = CInt(Left(wks.Cells(2, 3).Text, 2))
'Suchbegriff für Spieltag in Tipptabellen
vSpieltag = Format(lngDayRes, "0") & ". Spieltag"
For Each wkb In Workbooks
Select Case LCase(wkb.Name)
Case LCase(ThisWorkbook.Name), LCase("PERSONL.XLS")
'bei diesen Dateinamen keine Tabellen-Blätter auswerten
Case Else
'erstes Tabellenblatt der Mitspieler-Datei wird geprüft
With wkb.Worksheets(1)
'Spieltag in Tabelle suchen
Set rngSpieltag = .UsedRange.Find(what:=vSpieltag, LookIn:=xlValues, _
lookat:=xlPart)
If rngSpieltag Is Nothing Then
MsgBox vSpieltag & " in " & wkb.Name & " nicht gefunden!"
Else
'rngSpieltag auf Spieltags-Nummer oberhalb von den Tipps setzen
Set rngSpieltag = rngSpieltag.Offset(0, 3).Range("A1")
If rngSpieltag.Text "" _
And IsNumeric(rngSpieltag) Then
'Spieltag in Mitspieler-Tabelle in Zelle B15
lngDayPlr = rngSpieltag.Text
End If
'Prüfung Spieltag in Mitspieler-Tabelle
If lngDayPlr = lngDayRes Then
'Name in Mitspieler-Tabelle in Zelle H2 auslesen
sName = .Cells(27, 2).Text
'suche Zelle mit Tipper-Name in Resultat-Tabelle
Set rng = wks.UsedRange.Find(what:=sName, LookIn:=xlValues, _
lookat:=xlWhole)
If rng Is Nothing Then
MsgBox "Tipper " & sName & " in Tabelle " & wks.Name _
& " nicht gefunden!"
Else
'Tipps in Resultat-tabelle kopieren
rngSpieltag.Offset(1, 0).Resize(9, 3).Copy
rng.Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = 0
sMsg = sMsg & lngDayRes & ": " & sName & vbLf
End If
Else
MsgBox "Problem in " & wkb.Name & " " & vSpieltag & vbLf _
& "Spieltag-Text und Nummer passen nicht"
End If
End If
End With
End Select
Next
End If
Next
MsgBox "Daten aktualisiert von:" & vbLf & sMsg, , "Info"
Fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End If
End With
Application.ScreenUpdating = True
End Sub