AW: Markierter Bereich übernehmen
25.09.2016 19:41:31
Michael
Hi,
statt
ThisWorkbook.Sheets("SheetA").Range("F10:H22").Copy
dann
ThisWorkbook.Sheets("SheetA").Selection.Copy
wenn der Bereich zuvor bereits markiert wurde.
Soll der Bereich innerhalb Deiner Sub gewählt werden, kannst Du eine Inputbox mit Type=8 verwenden, siehe z.B. hier:
https://www.herber.de/mailing/vb/html/xlmthinputbox.htm
Dazu führst Du eine weitere Variable ein, z.B. insgesamt so (hier nur zum Testen):
Sub Bereich()
Dim zuKopieren as Range
Set zuKopieren = Application.InputBox("Bereich wählen", Type:=8)
MsgBox zuKopieren.Address ' gibt die gewählte Adresse aus
zuKopieren.Copy Range("L5") ' kopiert den Bereich direkt
End Sub
D.h., wenn Du diese Zeilen vor dem Öffnen der externen Datei einfügst, steht Dir der gewählte Bereich weiter unten zur Verfügung, so daß sich die oben zuerst genannte Zeile einfach durch das
zuKopieren.Copy
ersetzen ließe.
Allerdings muß der Fall, daß der Anwender keinen Bereich wählt, mit on error abgefangen werden.
Das würde dann insgesamt so aussehen:
Sub MappeOeffnen()
Dim strOrdner As String, strdateiname As String
Dim wbMappe As Workbook, bolWasOpen As Boolean
Dim lngNext As Long
Dim zuKopieren
On Error GoTo ErrExit
Set zuKopieren = Application.InputBox("Bereich wählen", Type:=8)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
strOrdner = "C:\Dein\Ordner\"
strdateiname = "Auswertung.xls"
bolWasOpen = True
On Error Resume Next
Set wbMappe = Workbooks(strdateiname)
On Error GoTo ErrExit
If wbMappe Is Nothing Then
bolWasOpen = False
If Dir(strOrdner & strdateiname) "" Then
Set wbMappe = Workbooks.Open(strOrdner & strdateiname, UpdateLinks:=False)
Else
MsgBox "Folgende Datei existiert nicht : " & vbLf & vbLf & _
strOrdner & strdateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !"
End If
End If
If Not wbMappe Is Nothing Then
With wbMappe.Sheets("SheetB")
lngNext = Application.Max(10, .Cells(.Rows.Count, 3).End(xlUp).Row + 1)
' ThisWorkbook.Sheets("SheetA").Range("F10:H22").Copy
' ThisWorkbook.Sheets("SheetA").Selection.Copy
zuKopieren.Copy ' ***
.Cells(lngNext, 3).PasteSpecial xlPasteValues
End With
If Not bolWasOpen Then
wbMappe.Close True
End If
End If
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "Sub 'MappeOeffnen'" & vbLf & String(40, "=") _
& vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation, "Fehler in Modul - Modul3"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
Set wbMappe = Nothing
End Sub
Schöne Grüße,
Michael