Bei Datenübernahme Änderung Format
01.08.2018 13:40:20
Patrick
ich übernehme Daten aus einer Datei in eine andere per Makro, welches über eine Userform gestartet wird. Hierbei werden nur Daten aus der markierten Zeile übernommen. So weit so gut. Eine Kleinigkeit funktioniert leider nicht und ich verzweifle an der Lösung:
In der Datei, in der die Daten liegen und übernommen werden sollen, ist in einer Zeile (B) mit (hh:mm) formatiert, denn hier steht eine Uhrzeit. Dieses ist für diese Datei so notwendig. In der Datei, in die diese Daten übernommen werden sollen, muss das Feld jedoch als Text formatiert werden.
Es geht um die Zeile
.Range("K11") = objRange.Cells(1, 2).Value
Um den Sachverhalt besser zu verstehen, hier nochmal das komplette Makro:
Sub getData()
Dim objWB As Workbook, objRange As Object, bolAlreadyOpen As Boolean
Const cstrFilePath As String = "G:\Pfad zu Excel-Datei aus der übernommen werden soll" ' _
_
Datei aus der die Daten geholt werden
Const cstrTargetTabel As String = "Aufgaben" 'Tabellenname in der Zieldatei
On Error GoTo ErrorHandler
With Application
.EnableEvents = False
.AskToUpdateLinks = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For Each objWB In Application.Workbooks
If objWB.FullName = cstrFilePath Then bolAlreadyOpen = True: Exit For
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(cstrFilePath)
Range("A1").Select
DoEvents
With ThisWorkbook.Sheets(cstrTargetTabel)
On Error Resume Next
Set objRange = Application.InputBox("Bitte zu übernehmende Zeile markieren", "Daten _
kopieren", ActiveCell.Address, Type:=8)
Err.Clear: On Error GoTo ErrorHandler
If Not objRange Is Nothing Then
Set objRange = objRange.Cells(1, 1).EntireRow
.Range("T11") = objRange.Cells(1, 10).Value
.Range("F11") = objRange.Cells(1, 1).Value
.Range("K11") = objRange.Cells(1, 2).Value
.Range("T7") = objRange.Cells(1, 4).Value
.Range("K7") = objRange.Cells(1, 5).Value
.Range("F13") = objRange.Cells(1, 9).Value
.Range("F9") = objRange.Cells(1, 11).Value
.Range("K9") = objRange.Cells(1, 12).Value
End If
End With
If Not bolAlreadyOpen Then objWB.Close False
ErrorHandler:
If Err.Number 0 Then
MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "getData" & vbLf & _
"Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
Err.Clear
End If
With Application
.EnableEvents = True
.AskToUpdateLinks = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Unload Userform_Terminerfassung
Set objRange = Nothing
Set objWB = Nothing
Call Auto_Open
End Sub
Ich freue mich über jede Anregung zur Lösung ;-)
Gruß und Danke,
Patrick