AW: Einlesen von Daten aus anderer Excel-Datei
05.06.2008 12:04:07
Daten
Hallo Andreas,
das folgende Makro, sucht so lange in Spalte 4 nach leere Zellen bis in Spalte 2 eine leere Zelle ist. Ist Spalte 4 leer, wird der Dateiname abgefragt bzw. ist zu bestätigen. Danach werden die Formeln kopiert und der Dateiname erstzt. in Spalte E-mail wird Hyperlink gesetzt.
Vor dem Start des Makros muss du die Namen/Vornamen der Tipper eintragen, deren Tippdateien vorligen.
Eine formellose übernahme der Tippdaten wäre auch möglich, aber das ist doch eine ziemliche Fleissarbeit all die auszulesenden Zelladressen rauszu picken und dann in der richtigen Zeile/Spalte die Werte einzufügen.
Gruß
Franz
Sub Tipps_Verknuepfen()
'Kopiert die Formeln in die nächste Freie Zeile und fragt Dateiname ab
Dim lngZeile As Long, strNameDatei As String, lngZeileKopie As Long
Dim objWks As Worksheet
Const lngLetzeSpalte As Long = 85 'Nummer der letzten Spalte die mit kopiert werden soll
Set objWks = ActiveSheet
With objWks
'leere Zeile in Spalte 4 ab Zeile 4 suchen
For lngZeile = 4 To .Cells(.Rows.Count, 2).End(xlUp).Row
'Leere Zellen in Spalte 4
If IsEmpty(.Cells(lngZeile, 4)) Then
'Neuen Dateinamen aus Name errechnen
.Cells(lngZeile, 2).Select
strNameDatei = "EM_Tipp_" & .Cells(lngZeile, 2).Value & ".xls"
strNameDatei = InputBox(Prompt:="Bitte ggf. Dateiname für " & vbLf & vbLf _
& .Cells(lngZeile, 2).Value & " " & .Cells(lngZeile, 3).Value & vbLf & vbLf _
& " korrigieren und Eingabe mit OK bestätigen" & vbLf _
& "Bei Abbrechen wird die Zeile übersprungen!", _
Title:="EM 2008 Tippspiel - Tipps einlesen", Default:=strNameDatei)
If strNameDatei = "" Then
Else
lngZeileKopie = .Cells(.Rows.Count, 4).End(xlUp).Row
.Range(.Cells(lngZeileKopie, 4), .Cells(lngZeileKopie, lngLetzeSpalte)).Copy _
Destination:=.Cells(lngZeile, 4)
'Dateiname in Formeln ersetzen
.Range(.Cells(lngZeile, 4), .Cells(lngZeile, lngLetzeSpalte)).Replace _
What:="[*]", Replacement:="[" & strNameDatei & "]", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'E-Mail-Hyperlink einfügen
If .Cells(lngZeile, 5).Value "" Then
.Hyperlinks.Add Anchor:=.Cells(lngZeile, 5), Address:= _
"mailto:" & .Cells(lngZeile, 5).Value & "?subject=EM%202008%20-%20Tippspiel"
End If
End If
End If
Next
End With
End Sub