Hallo zusammen,
ich benötige mal wieder Eure Hilfe:
Ich möchte den Inhalt der Zellen A15, A18 und A21 der geöffneten
Datei in eine Datei auf dem Serverlaufwerk X:\Alle\A\ErnstR\Test_Ziel.xls
in die Zellen B16, C17 und D18 schreiben.
Dafür habe ich mich an folgendem Code von Sepp versucht.
Das Öffnen der Datei auf dem Server klappt noch, aber das
Übertragen der Daten nicht mehr.
Kann jemand helfen?
(WinXp, Xl2003)
Gruß und danke schonmal.
Rolf
Option Explicit
Sub WriteData()
Dim objADOfield As Object
Dim myFile As String, myTable As String
Dim varValue1 As String, varValue2 As String, varValue3 As String
On Error GoTo ErrExit
myFile = "X:\Alle\A\ErnstR\test\_Ziel.xls"
'ChDrive "x"
'ChDir "x:\Alle\A\ErnstR"
Workbooks.Open "X:\Alle\A\ErnstR\test\_Ziel.xls"
Sheets("Tabelle1").Select
Range("A1").Select
If myFile = "Falsch" Then Exit Sub
'myTable = "Test\_Ziel"
With ThisWorkbook.Sheets("Tabelle1")
varValue1 = .Range("A15").Value 'Wert der nach "B15" übertragen wird
varValue2 = .Range("A18").Value 'Wert der nach "B18" übertragen wird
varValue3 = .Range("A21").Value 'Wert der nach "B21" übertragen wird
End With
With ExcelTable(myFile, myTable, "A1:J25")
.Move 23
.Range("B16") = varValue1
.Range("C17") = varValue2
.Range("D18") = varValue3
.Update
.Close
End With
ErrExit:
If Err.Number 0 Then
MsgBox "Beim übertragen der Werte ist ein Fehler aufgetreten!" & Space(15), 48, "Hinweis"
Else
MsgBox "Werte wurden erfolgreich übertragen!" & Space(15), 64, "Hinweis"
End If
End Sub
Public Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String) As Object
Dim SQL As String
Dim Con As String
On Error Resume Next
SQL = "select \* from [" & Table & "$" & SourceRange & "]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" \_
& "Extended Properties=Excel 8.0;" \_
& "Data Source=" & Path & ";"
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 1, 3
End Function
)