Habe Code etwas erweitert ...
18.02.2021 11:18:49
Dieter(Drummer)
... habe eine MsgBox mit Anwendungshinweisen zugefügt und zusätzlich eine Sprachausgabe mit Handling Hinweisen. Wärend der Sprachausgabe kann dennoch direkt weiter gearbeitet werden. Evtl. haben noch andere dafür Verwendung.
Danke nochmal für deine Variante und natürlich auch die Varianten der anderen Spezialsten.
Gruß, Dieter(Drummer)
Hier der jetzige Code:
''In diesem Beispiel bleibt die Quell-Mappe geschlossen.
'In diesem Beispiel liegen Quell- und Zielmappe im gleichen Verzeichnis.
'Anpassung einzufügender Bereich. Herber: von Rudi Maintaire am 16.02.2021 14:42:07
'Variante 4. Herber: von Rudi Maintaire am 17.02.2021 10:49:23 und am 17.02.2021 13:21:11
Sub AuslesenGeschlDatei_4()
Dim sFile As String, sPath As String
Dim rngZiel As Range
Dim strQuelle As String
Dim rngQuelle As Range
Application.Speech.Speak ("Achtung: In der erste Inputbox den Kopierbereich eingeben, z.B. A3: _
A5, In zweiter Inputbox Startzelle eingeben oder in aktueller Datei anklicken. Nach OK kann optional derb Ordner, der Qelldaten enthält, ausgewählt werden, oder Abbrechen wählen, dann werden Daten aus dem Ordner gewählt, der Quell- und aktuellen Datei enhält"), SpeakAsync:=True
MsgBox "Handling:" & vbLf & vbLf & "In 1. Inputbox Kopierbereich eingeben, z.B. A3:A5" & _
vbLf & _
"in 2. Inputbox Startzelle eingeben oder in aktueller Datei anklicken." & vbLf & vbLf & _
"Nach OK kann optional der Ordner, der Qelldaten enthält," & vbLf & _
"ausgewählt werden, oder Abbrechen wählen. Dann werden Daten" & vbLf & _
"aus dem Ordner gewählt, der Quell- und die aktuellen Datei enhält.", 64, "Hinweis"
strQuelle = InputBox("Adresse: Quellbereich (Zellbereich) eingeben")
On Error Resume Next
Set rngQuelle = ActiveSheet.Range(strQuelle)
Set rngZiel = Application.InputBox("Zielereich auswählen:", "Bereichsauswahl", , , , , , _
8)
On Error GoTo 0
If rngZiel Is Nothing Or rngQuelle Is Nothing Then
MsgBox "Abbruch oder ungültige Eingabe.", vbCritical
Else
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
sPath = .SelectedItems(1)
Else
sPath = ThisWorkbook.Path
End If
End With
sPath = sPath & "\"
Set rngZiel = rngZiel.Resize(rngQuelle.Rows.Count, rngQuelle.Columns.Count)
sFile = "TestKopie_1" 'geschlossene Datei
With rngZiel
.Formula = "='" & sPath & "[" & sFile & "]Tabelle1'!" & rngQuelle(1).Address(0, 0)
.Value = .Value
End With
End If
End Sub