Datenübername aus anderer Datei

Hallo zusammen,
meine VBA-Kenntnisse werden zwar größer, reichen aber leider hierfür noch nicht.
Ich möchte aus einer Datei die Möglichkeit einer Datenübernahme aus einer anderen Datei ermöglichen.
Konkret:
Ich klicke auf Button X, hierdurch wird Datei xxx geöffnet. Ich markiere z.b. Zeile 8 und es werden aus dieser Zeile die Werte aus A8, B8, D8, E8, I8, K8, L8 jeweils kopiert und in die eigentliche Datei in (fest, nicht per Markierung) Zelle F11, K11, T7, K7, F13, F9, K9 übernommen.
Wichtig, die Datei, aus welcher die Daten übernommen werden sollen, ist mit Passwort geschützt.
Ist dieses möglich und verständlich?
Wenn ja, wie kann ich dieses schaffen?
Gruß und schon ein schönes Wochenende
Patrick

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Patrick,
probier mal.
Modul Modul1

Option Explicit 
 
Sub getData() 
  Dim objWB As Workbook, objRange As Object, bolAlreadyOpen As Boolean 
 
  Const cstrFilePath    As String = "D:\Forum\test.xlsx"    'Datei aus der die Daten geholt werden - ANPASSEN! 
   
  Const cstrTargetTabel As String = "Tabelle1"              'Tabellenname in der Zieldatei - ANPASSEN! 
 
  On Error GoTo ErrorHandler 
 
  With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .AskToUpdateLinks = False 
    .DisplayAlerts = False 
    .Calculation = xlCalculationManual 
  End With 
 
  For Each objWB In Application.Workbooks 
    If objWB.FullName = cstrFilePath Then bolAlreadyOpen = True: Exit For 
  Next 
 
  If objWB Is Nothing Then Set objWB = Workbooks.Open(cstrFilePath) 
 
  With ThisWorkbook.Sheets(cstrTargetTabel) 
    On Error Resume Next 
    Set objRange = Application.InputBox("Bitte Zeile auswählen!", "Daten kopieren", ActiveCell.Address, Type:=8) 
    Err.Clear: On Error GoTo ErrorHandler 
    If Not objRange Is Nothing Then 
      Set objRange = objRange.Cells(1, 1).EntireRow 
      .Range("F11") = objRange.Cells(1, 1).Value 
      .Range("K11") = objRange.Cells(1, 2).Value 
      .Range("T7") = objRange.Cells(1, 4).Value 
      .Range("K7") = objRange.Cells(1, 5).Value 
      .Range("F13") = objRange.Cells(1, 9).Value 
      .Range("F9") = objRange.Cells(1, 11).Value 
      .Range("K9") = objRange.Cells(1, 12).Value 
    End If 
  End With 
 
  If bolAlreadyOpen Then objWB.Close False 
 
ErrorHandler: 
 
  If Err.Number <> 0 Then 
    MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "getData" & vbLf & _
      "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
      IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!" 
    Err.Clear 
  End If 
 
  With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .AskToUpdateLinks = True 
    .DisplayAlerts = True 
    .Calculation = xlCalculationAutomatic 
  End With 
 
  Set objRange = Nothing 
  Set objWB = Nothing 
End Sub 
 
 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

	A	B	C	D	E	F
1	Gruß Sepp
2
3

If Not bolAlreadyOpen Then objWB.Close False VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Option Explicit Sub getData() Dim objWB As Workbook, objRange As Object, bolAlreadyOpen As Boolean Const cstrFilePath As String = "D:\Forum\test.xlsx" 'Datei aus der die Daten geholt werden - ANPASSEN! Const cstrTargetTabel As String = "Tabelle1" 'Tabellenname in der Zieldatei - ANPASSEN! On Error GoTo ErrorHandler With Application .EnableEvents = False .AskToUpdateLinks = False .DisplayAlerts = False .Calculation = xlCalculationManual End With For Each objWB In Application.Workbooks If objWB.FullName = cstrFilePath Then bolAlreadyOpen = True: Exit For Next If objWB Is Nothing Then Set objWB = Workbooks.Open(cstrFilePath) DoEvents With ThisWorkbook.Sheets(cstrTargetTabel) On Error Resume Next Set objRange = Application.InputBox("Bitte Zeile auswählen!", "Daten kopieren", ActiveCell.Address, Type:=8) Err.Clear: On Error GoTo ErrorHandler If Not objRange Is Nothing Then Set objRange = objRange.Cells(1, 1).EntireRow .Range("F11") = objRange.Cells(1, 1).Value .Range("K11") = objRange.Cells(1, 2).Value .Range("T7") = objRange.Cells(1, 4).Value .Range("K7") = objRange.Cells(1, 5).Value .Range("F13") = objRange.Cells(1, 9).Value .Range("F9") = objRange.Cells(1, 11).Value .Range("K9") = objRange.Cells(1, 12).Value End If End With If Not bolAlreadyOpen Then objWB.Close False ErrorHandler: If Err.Number <> 0 Then MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "getData" & vbLf & _ "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _ IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!" Err.Clear End If With Application .EnableEvents = True .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With Set objRange = Nothing Set objWB = Nothing End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

321 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datenübername aus anderer Datei

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

321 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread