Fehler: Typen unverträglich
04.12.2015 15:31:20
Sascha
woran liegt dieser o.g. Fehler? Kann mir jemand weiterhelfen? (Ganz unten fett markiert)
Sub Datentransport()
'Globale Variablen
Dim strDeckblatt As String: strDeckblatt = "Deckblatt"
Dim strMetalle As String: strMetalle = "Metalle"
Dim strMethoden As String: strMethoden = "Methodenzuordnung"
Dim wbQuellmappe As Workbook: Set wbQuellmappe = ActiveWorkbook
Dim strZielpfad As String: strZielpfad = "C:\Users\oxshein\Desktop"
Dim strZieldatei As String: strZieldatei = "Ziel.xlsm"
Dim wbZielmappe As Workbook
Dim strZieltabelle As String: strZieltabelle = "Gesamt"
Dim wksZieltabelle As Worksheet
Dim rngLetzteZelle As Range
Dim lngLetzteZeile As Long
'Methoden werden eingelesen zum späteren Vergleich und der Zuordnung zur richtigen Spalte
Dim arrMethodenGesamt(92, 1) As String
For i = 0 To UBound(arrMethodenGesamt) - LBound(arrMethodenGesamt)
arrMethodenGesamt(i, 0) = Sheets(strMethoden).Range("A" & i + 1)
arrMethodenGesamt(i, 1) = Sheets(strMethoden).Range("B" & i + 1)
Next i
'Zielmappe wird gegebenenfalls geöffnet
If istArbeitsmappeOffen(strZieldatei) Then
Set wbZielmappe = Application.Workbooks(strZieldatei)
bolOpen = True
Else
Set wbZielmappe = Application.Workbooks.Open(strZielpfad & Application.PathSeparator & _
_
_
_
strZieldatei)
bolOpen = False
End If
'Zieltabelle wird gesetzt
Set wksZieltabelle = wbZielmappe.Worksheets(strZieltabelle)
With wksZieltabelle
' METALLE |
If wbQuellmappe.Worksheets(strDeckblatt).Range("I20") > 0 Then
'Erzeuge Array mit Proben und Methoden
Dim arrProbenMetalle(7, 8) As String
Dim intProbeMetalleEntahlten As Integer: intProbeMetalleEntahlten = -1
Dim x As Integer: x = 0 'Zählvariable für die Proben(-anzahl)
For Each probe In wbQuellmappe.Worksheets(strMetalle).Range("D19:D26")
'Wenn eine Probe eingetragen ist
If (probe = "") = False Then
'Überprüfe ob die Probe sich bereits im Array befindet
For i = 0 To UBound(arrProbenMetalle, 1) - LBound(arrProbenMetalle, 1)
If arrProbenMetalle(i, 0) = probe Then
'Wenn ja, dann speichere die Position
intProbeMetalleEntahlten = i
Exit For
End If
Next i
'Wenn die Probe bereits bekannt ist, dann speichere die Methode in der _
_
_
_
2ten Dimension
If intProbeMetalleEntahlten > -1 Then
'MsgBox ("Probe ist enthalten: " & probe)
For i = 1 To UBound(arrProbenMetalle, 2) - LBound(arrProbenMetalle, _
_
_
_
2)
If arrProbenMetalle(intProbeMetalleEntahlten, i) = "" Then
arrProbenMetalle(intProbeMetalleEntahlten, i) = Sheets( _
strMetalle).Range("S" & probe.Row).Value
Exit For
End If
Next i
Else
'MsgBox ("Neue Probe hinzugefügt: " & probe)
arrProbenMetalle(x, 0) = probe
For i = 1 To UBound(arrProbenMetalle, 2) - LBound(arrProbenMetalle, _
_
_
_
2)
If arrProbenMetalle(x, i) = "" Then
arrProbenMetalle(x, i) = wbQuellmappe.Worksheets(strMetalle) _
_
_
_
.Range("S" & probe.Row)
Exit For
End If
Next i
x = x + 1
End If
End If
intProbeMetalleEntahlten = -1
Next probe
'Übertragung der Daten in die Zieltabelle
For i = 0 To UBound(arrProbenMetalle, 1) - LBound(arrProbenMetalle, 1)
If (arrProbenMetalle(i, 0) = "") = False Then
'Nächste Einfüge-Zeile ermitteln
Set rngLetzteZelle = .Cells.Find(What:="*", After:=Range("A1"), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If rngLetzteZelle Is Nothing Then
lngLetzteZeile = 1
Else
lngLetzteZeile = rngLetzteZelle.Row + 1
End If
'Laufende Nummer einfügen
If IsNumeric(.Cells(rngLetzteZelle.Row, "A")) = True Then
.Cells(lngLetzteZeile, "A") = .Cells(rngLetzteZelle.Row, "A") + 1
Else
.Cells(lngLetzteZeile, "A") = 1
End If
'Übertrage Daten vom Deckblatt
'Auftraggeber: A3
.Cells(lngLetzteZeile, "I") = wbQuellmappe.Worksheets(strDeckblatt). _
Range("A3")
'Auftragsdatum: P3
.Cells(lngLetzteZeile, "J") = wbQuellmappe.Worksheets(strDeckblatt). _
Range("P3")
'Kostenstelle: P6
.Cells(lngLetzteZeile, "N") = wbQuellmappe.Worksheets(strDeckblatt). _
Range("P6")
'Projektname: A10
.Cells(lngLetzteZeile, "E") = wbQuellmappe.Worksheets(strDeckblatt). _
Range("A10")
'Unterprojektname: K10
.Cells(lngLetzteZeile, "F") = wbQuellmappe.Worksheets(strDeckblatt). _
Range("K10")
'Übertrage Daten von Metalle
'Probename
.Cells(lngLetzteZeile, "D") = arrProbenMetalle(i, 0)
'Methoden
For k = 0 To UBound(arrProbenMetalle, 2) - LBound(arrProbenMetalle, 2)
'TODO: Array durchlaufen und zuordnen
For j = 0 To UBound(arrMethodenGesamt) - LBound(arrMethodenGesamt)
If arrProbenMetalle(i, k) = arrMethodenGesamt(j, 0) Then
Dim s As String: s = arrMethodenGesamt(j, 1)
.Cells(lngLetzteZeile, s) = 1
Exit For
End If
Next j
Next k
End If
Next i
End If
End With
End Sub
'Prüft ob Zielarbeitsmappe geöffnet ist
Public Function istArbeitsmappeOffen(ByVal strName As String) As Boolean
Dim wb As Workbook
On Error GoTo Fehler
istArbeitsmappeOffen = True
Set wb = Application.Workbooks(strName)
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
istArbeitsmappeOffen = False
End Select
End With
End Function