Sheets über Dateiexplorer einzeln auswählen?
26.03.2017 10:39:43
Leon
Hallo, habe folgendes Problem.
Mit unten stehenden Code kann ich über den Dateiexplorer eine Mappe auswählen.
Es befinden sich in der Mappe aber mehrere "Tabellenblätter".
Die Mappe soll nicht "sichtbar" geöffnet werden, sondern im Hintergrund nur von einem bestimmten Tabellenblatt - dessen Inhalt- kopiert werden.
Ist es möglich, folgendes über ein "Auswahlfenster" ,einer MSG Box oder über ein Dialog- Feld folgendes zu Realisieren?
* Feststellung welche Worksheet existieren
* Nun die einzelnen Worksheet anzeigen und für den Kopiervorgang markierbar machen.
es würde auch reichen, wenn hier nur Worksheet "Tabelle1" und "Bearbeiten" - angezeigt - aufgelistet -werden. Um diese zwei geht es, alle anderen in der Mappe vorkommenden "Blätter" können ignoriert werden.
* wenn dieses dann Markiert wurde- dessen Inhalt Kopieren - und in das "aktive Tabellenblatt" mit dem Namen " Bearbeiten " einfügen.
Option Explicit
_______________________________________________________________________
Sub Zum_Testen_Datei_öffnen() ' so testen
Dim myFile As String
Dim myWrkb As Workbook
myFile = SelectFile
Set myWrkb = GetWorkbook(myFile)
End Sub
____________________________________________________________________________________
Function SelectFile() As String ' Datei Explorer Öffnen
Dim fileDlg As FileDialog
Set fileDlg = Application.FileDialog(msoFileDialogOpen)
With fileDlg
.InitialFileName = "D:\Eigene_Datein"
.Filters.Add "Excel File", "*.xl*", 1
.AllowMultiSelect = False
If fileDlg.Show = False Then
SelectFile = ""
Else
SelectFile = fileDlg.SelectedItems(1)
End If
End With
End Function
____________________________________________________________________________________
Function GetWorkbook(ByVal sFullName As String) As Workbook ' hiermit die Datei öffnen
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Workbooks.Open(sFullName)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
__________________________________________________________________________________
Function CopySheet(Sh As Worksheet, trgWrkb As Workbook) As Boolean ' kopieren
On Error GoTo EH
Sh.Copy before:=trgWrkb.Sheets(1)
CopySheet = True
Exit Function
EH:
MsgBox Sh.Name & " was not copied", vbCritical, "Sheet copy failed"
CopySheet = False
End Function
____________________________________________________________________________________
Sub Dateiauswahl_Bearbeitung() 'Dateiauswahl für Bearbeitung als Ausführungsbefehl
Dim myFile As String
Dim myWrkb As Workbook
myFile = SelectFile
Set myWrkb = GetWorkbook(myFile)
CopySheet myWrkb.Sheets(1), ThisWorkbook
myWrkb.Close savechanges:=False
CloseWorkbook myFile, False
______________________________________________________________________________________
End Sub
Function CloseWorkbook(ByVal sFullName As String, saveWrkBk As Boolean) As Boolean ' _
Dateiauswahl wieder schließen
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
On Error GoTo 0
If wbReturn Is Nothing Then
CloseWorkbook = False
Else
wbReturn.Close savechanges:=saveWrkBk
CloseWorkbook = True
End If
End Function
________________________________________________________________________________
Kann mir jemand beim Code helfen?
Grüße Leon