AW: Text in anderer Datei suchen, kopiertes rechts ein
15.09.2008 12:26:03
Rudolf
Hab es mal so Laienhaft geändert.
Die Stationen haben ja auch nicht die Zieldatei und so habe sie wenn sie auf den Button klicken der nur für das Büro gedacht ist dann nur die Meldung "Nur für Fr.Romes"
Sub DatenKopieren() hab hier Private weggeholt (wußte sonst nicht wie ich das ansprechen _
konnte, sorry)
Dim varSuchen, lngZeileZiel As Long, rngSuchen As Range
Dim wbZiel As Workbook
Dim wbQuelle As Workbook
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Const strPfad As String = "D:\Test2\" 'Verzeichnis der Zieldatei
Const strZieldatei As String = "Ziel_neu.xls" 'Name der Zieldatei
On Error GoTo ende
Set wbQuelle = ActiveWorkbook
If MsgBox("Daten kopieren", vbOKCancel, "Daten nach Zieldatei kopieren") = vbOK Then
'Prüfen, ob Zieldatei schon geöffnet
For Each wbZiel In Workbooks
If LCase(wbZiel.Name) = LCase(strZieldatei) Then Exit For
Next
If wbZiel Is Nothing Then
'Zieldatei öffnen, wenn nicht geöffnet
Set wbZiel = Workbooks.Open(Filename:=strPfad & "\" & strZieldatei)
End If
Set wksQuelle = wbQuelle.Worksheets("Tabelle1") 'Quellen-Blatt in Datei 1
'Suchwert aus Zelle A3 in Quelldatei-Tabelle1 auslesen
varSuchen = wksQuelle.Range("A3").Value
If varSuchen "" Then
'Tabellenblatt in der Zieldatei setzen
Set wksZiel = wbZiel.Worksheets("Tabelle2")
'Zieldatei anzeigen
wbZiel.Activate
'Zieltabelle anzeigen
wksZiel.Activate
'Eingabewert im Zielblatt Spalte A suchen
Set rngSuchen = wksZiel.Columns(1).Find(what:=varSuchen, LookIn:=xlValues, lookat:= _
xlWhole)
If rngSuchen Is Nothing Then
MsgBox "Suchbegriff im Zielblatt nicht gefunden!"
Else
'Daten aus Datei 1 in gefundener Zeile in Zieltabelle Spalte C kopieren
lngZeileZiel = rngSuchen.Row
wksQuelle.Range("B6:O6").Copy Destination:=wksZiel.Cells(lngZeileZiel, 3)
End If
wksZiel.Range("A1").Select
GoTo end3
End If
End If
' wbQuelle.Close savechanges:=True
' Set wbQuelle = Nothing
GoTo end2
end2:
ende:
If Err.Number 0 Then
MsgBox " Nur für Fr. Romes! "
'MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
End If
end3:
End Sub
Fett die Änderungen.
Gruß
Rudolf