AW: Hilfszelle für Zeilebestimmung, welche kopiert wer
26.07.2011 11:15:04
Tino
Hallo,
ich war nicht so schnell wie Franz,
aber jetzt wo der Code schon mal fertig ist stelle ich ihn einfach hier rein.
Wenn Du Lust hast kannst Du ihn ja mal testen, evtl. noch den Pfad zur Email.xls anpassen.
Sub Kopiere_X()
Dim oWBEx As Workbook, strPath$, booIsOben As Boolean
Dim rngCopy As Range, rngTmp As Range
With ThisWorkbook.Sheets("TrackingListe")
For Each rngTmp In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
If rngTmp = "x" Then
If rngCopy Is Nothing Then
Set rngCopy = rngTmp.Offset(0, 1).Resize(, 16)
Else
Set rngCopy = Union(rngCopy, rngTmp.Offset(0, 1).Resize(, 16))
End If
End If
Next rngTmp
End With
If Not rngCopy Is Nothing Then
With Application
.ScreenUpdating = False
.EnableEvents = False
'Pfad zur Email.xls
strPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", _
ThisWorkbook.Path, ThisWorkbook.Path & "\")
strPath = strPath & "Email.xls"
Set oWBEx = Check_Mappe(strPath) 'prüfen ob geöffnet
If oWBEx Is Nothing Then
Set oWBEx = Workbooks.Open(strPath)
Else
booIsOben = True
End If
With oWBEx
If Not .ReadOnly Then
With oWBEx.Sheets("Fallliste")
rngCopy.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With 'oWBEx.Sheets("Fallliste")
.Save
If Not booIsOben Then .Close False
MsgBox "Daten wurden kopiert und gespeichert"
Else
MsgBox "Datei '" & oWBEx.Name & "' ist Schreibgeschützt", vbCritical
If Not booIsOben Then
.Close False
End If
End If
End With 'oWBEx
.ScreenUpdating = True
.EnableEvents = True
End With 'Application
End If
End Sub
Function Check_Mappe(strFullName$) As Workbook
Dim oWB As Workbook
For Each oWB In Application.Workbooks
If oWB.FullName = strFullName Then
Set Check_Mappe = oWB
Exit For
End If
Next
End Function
Gruß Tino