AW: doppelter laufwerk
23.06.2015 20:06:27
fcs
Hallo domi,
nachfolgend ein Makro und 2 Functions, die du dir dann entsprechend einbauen/anpassen musst.
Gruß
Franz
'Makro erstellt unter Excel 2010 -WIndows Vista
'Makros in einem allgemeinen Modul der Datei einfuegen und dann einer Schaltflaeche zuweisen
Sub Tab_Personalnummer_aus_Arbeit_xls_holen()
Dim wkbZiel As Workbook
Dim wkbArbeit As Workbook
Dim strPfad As String, strDatei As String, strPfadDatei As String
Dim strBlatt As String, strMsg As String
'in den naechsten 3 Zeilen Pfad und Namen ggf. anpassen
strPfad = "G:" 'ohne "\" am Ende !!!
strDatei = "Arbeit.xls"
strBlatt = "Personalnummer"
strPfadDatei = strPfad & Application.PathSeparator & strDatei
strMsg = "Tabelle ""Personalnummer"" aus " & strDatei & " kopieren"
Application.ScreenUpdating = False
'Prüfung, ob Datei existiert
If Dir(strPfadDatei) = "" Then
MsgBox "Datei" & vbLf & strPfadDatei & vbLf & "nicht gefunden!", vbOKOnly, strMsg
'Prüfung, ob Datei in Anwendung geöffnet ist
ElseIf fncWorkbookOpen(strWorkbook:=strDatei) = True Then
MsgBox "Datei""" & strDatei & vbLf & """ ist geöffnet!" & vbLf _
& "Bitte Datei erst schließen", vbOKOnly, strMsg
Else
Set wkbZiel = ActiveWorkbook
'Prüfung, ob Blatt in Zieldatei vorhanden
If fncSheetVorhanden(strSheet:=strBlatt, wkb:=wkbZiel) Then
Select Case MsgBox("Blatt """ & strBlatt & """ ist schon vorhanden! " & vbLf _
& "Blatt löschen?", vbQuestion + vbOKCancel, strMsg)
Case vbOK
Application.DisplayAlerts = False
wkbZiel.Sheets(strBlatt).Delete
Application.DisplayAlerts = True
Case vbCancel
GoTo Beenden
End Select
End If
Set wkbArbeit = Application.Workbooks.Open(Filename:=strPfadDatei, ReadOnly:=True)
'Prüfung, ob Blatt in Quelldatei vorhanden
If fncSheetVorhanden(strSheet:=strBlatt, wkb:=wkbArbeit) Then
wkbArbeit.Worksheets("Personalnummer").Copy after:=wkbZiel.Sheets(1)
Else
MsgBox "Blatt """ & strBlatt & """ in Datei """ & strDatei & """ nicht vorhanden! ", _
_
vbQuestion + vbOKCancel, strMsg
End If
wkbArbeit.Close savechanges:=False
End If
Beenden:
Application.ScreenUpdating = True
End Sub
Public Function fncSheetVorhanden(strSheet As String, Optional wkb As Workbook) As Boolean
'Prüft, ob Blatt strSheet in Workbook schon vorhanden
Dim objSheet
If wkb Is Nothing Then Set wkb = ActiveWorkbook
On Error GoTo Fehler
Set objSheet = wkb.Sheets(strSheet)
fncSheetVorhanden = True
Fehler:
End Function
Public Function fncWorkbookOpen(strWorkbook As String) As Boolean
'Prüft, ob Arbeitsmappe strWorkbook in aktiver Excel-Anwendung nicht geöffnet ist
Dim wkb As Workbook
On Error GoTo Fehler
Set wkb = Application.Workbooks(strWorkbook)
fncWorkbookOpen = True
Fehler:
End Function