Import aus Excel-File bis Zeile leer ist

Hallo zusammen
Ich stufe meine VBA Kenntnisse noch als recht bescheiden ein. Ich konnte aber bereits mit Hilfe diesem Forum und Google erste VBA Makros programmieren.
Aktuell beschäftige ich mich mit einem Mako, welches von einem geschlossenen Excel File eines bestimmten Tab die Daten importiert/einfügt, welches jeweils im gleichen Ordner abgelegt ist, wie das Excel-File mit dem Makro. Dies klappt auch alles so wie es soll.
Das Problem ist nun jedoch, dass die zu einzufügenden Daten manchmal wenige Zeilen haben und manchmal hunderte von Zeilen. Gerne würde ich das VBA so anpassen, dass es jeweils nur solange die Daten einfügt bis eine Zeile des geschlossenen Tabs leer ist. Damit würde das Makro einiges flüssiger werden.
Ich hatte selber zwei Ideen. Die eine Idee wäre, die letzte leere Zeile des zu importierenden Tab auszulesen und diese im Range einzufügen . Die andere Variante wäre, den For Each so anzupassen, dass es nur solange ausgeführt wird, bis die Zeile nach dem Einfügen leer ist. Leider bin ich bei beiden Lösungsansätzen gescheitert.
Hier der aktuelle VBA Code, welcher aktuell nur die ersten 10 Zeilen importiert. Dies Werte ahbe ich nur zu Testzwecke, dass das Makro schnell fertig ist ;-)

Sub Bereich_auslesen()
'** Dimensionierung der Variablen
Dim pfad As String
Dim datei As String
Dim blatt As String
Dim bereich As Range
Dim zelle As Object
'** Angaben zur auszulesenden Zelle
pfad = ThisWorkbook.Path
datei = "ImportFile for Outlook by Manager.xlsx"
blatt = Range("G2")
Set bereich = Range("A2:C10")
'** Bereich auslesen
For Each zelle In bereich
'** Zellen umwandeln
zelle = zelle.Address(False, False)
'** Eintragen in Bereich
ActiveSheet.Cells(zelle.Row, zelle.Column).Value = GetValue(pfad, datei, blatt, zelle)
Next zelle
ActiveSheet.Range("A2", "A6").NumberFormat = "dd.mmm"
End Sub
Private Function GetValue(pfad, datei, blatt, zelle)
'** Daten aus geschlossener Arbeitsmappe auslesen
'*** Dimensionierung der Variablen
Dim arg As String
'Sicherstellen, dass das datei vorhanden ist
If Right(pfad, 1)  "\" Then pfad = pfad & "\"
If Dir(pfad & datei) = "" Then
GetValue = "datei Not Found"
Exit Function
End If
'** Das Argument erstellen
arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(zelle).Range("A1").Address(, ,  _
xlR1C1)
'** Auslesen über Excel4Macro
GetValue = ExecuteExcel4Macro(arg)
End Function

Vielen Dank im Voraus für eure Hilfe!
Liebe Grüsse aus der Zentralschweiz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub bereich_kopieren() Dim Pfad As String Dim wsZiel As Worksheet Dim wsQuelle As Worksheet Dim Sheet As String Pfad = ThisWorkbook.Path & "\ImportFile for Outlook by Manager.xlsx" Sheet = Range("G2") 'Zielblatt = aktive Datei, aktives Blatt Set wsZiel = ActiveWorkbook.ActiveSheet 'Quellblatt = Datei, Blatt 1 Set wsQuelle = Workbooks.Open(Pfad).Sheet wsQuelle.Cells.Copy Destination:=wsZiel.Cells 'Quelle schließen wsQuelle.Parent.Close Set wsQuelle = Nothing Set wsZiel = Nothing End Sub

Sub bereich_kopieren() Dim Pfad As String Dim wsZiel As Worksheet Dim wbQuelle As Workbook Dim wsQuelle As Worksheet Dim Sheet As String Pfad = ThisWorkbook.Path & "\ImportFile for Outlook by Manager.xlsx" Sheet = Range("G2") 'Zielblatt = aktive Datei, aktives Blatt Set wsZiel = ActiveWorkbook.ActiveSheet 'Quellblatt = Datei, Blatt 1 Set wbQuelle = Workbooks.Open(Pfad) Set wsQuelle = wbQuelle.Worksheets(".......") wsQuelle.Cells.Copy Destination:=wsZiel.Cells 'Quelle schließen wbQuelle.Close False Set wsQuelle = Nothing Set wsZiel = Nothing End Sub

Sub bereich_kopieren() Dim strPfad As String, strBlatt As String Dim wsZiel As Worksheet Dim wbQuelle As Workbook Dim wsQuelle As Worksheet Application.ScreenUpdating = False strPfad = ThisWorkbook.Path & "\ImportFile for Outlook by Manager.xlsx" strBlatt = Range("G2") 'Zielblatt = aktive Datei, aktives Blatt Set wsZiel = ActiveWorkbook.ActiveSheet 'Quellblatt = Datei, Blatt 1 Set wbQuelle = Workbooks.Open(strPfad) Set wsQuelle = wbQuelle.Worksheets(strBlatt) wsQuelle.Range("A2:C" & wsQuelle.Cells(Rows.Count, 1).End(xlUp).Row).Copy _ Destination:=wsZiel.Range("A1") 'Quelle schließen wbQuelle.Close False Set wsQuelle = Nothing Set wsZiel = Nothing End Sub

Hi
Also ich habe jetzt mal getestet.
Dummy-Datei auf Desktop mit Tabelle1, Tabelle2, Tabelle3.
Neue Datei mit Parameterfeld, Wert Tabelle1. Wie im Link meines ersten Beitrages beschrieben, Zelle benannt "BlattName", Zelle markiert, Abfrage aus Tabelle, Drilldown.
Danach die Hauptabfrage und im erweiterten Editor die fixe Angabe von Tabelle1 durch den Parameter ersetzt:
Quelle = Excel.Workbook(File.Contents("C:\Pfad\Desktop\PQTestInput.xlsx"), null, true),
Tabelle1_Sheet = Quelle{[Item=BlattName,Kind="Sheet"]}[Data],
#"Höher gestufte Header" = Table.PromoteHeaders(Tabelle1_Sheet, [PromoteAllScalars=true]),
Ging ratzfatz und hat ohne Sicherheitswarnung funktioniert. Ich musste auch keine Privacy Level auf Ignorieren setzen.
Ob es auch auf Sharepoint ginge, kann ich nicht testen. Aber probiere doch einfach mal, das Ganze hat mich nicht mehr als 5-10 Minuten Zeit gekostet. Es kann tatsächlich sein, dass eine externe Quelle eine Änderung der Datenschutzeinstellung erfordert.
Die Datenschutzeinstellung hat nichts mit Sicherheit (z.B. Viren o.ä.) zu tun, sondern mit der Geheimhaltung der Daten, welche du von extern beziehen willst. Machst du z.B. eine Webabfrage, wo die Daten sowieso öffentlich sind, dann spielt es m.E. auch keine Rolle, wenn jemand die Daten abfangen würde. Es wäre somit nur ein Problem, wenn in der externen Datei vertrauliche Daten vorhanden wären.
Security Note: Enabling Fast Combine by selecting Ignore the Privacy levels and potentially improve performance in the Workbook Settings dialog could expose sensitive or confidential data to an unauthorized person. Do not enable Fast Combine unless you are confident that the data source does not contain sensitive or confidential data.
https://support.microsoft.com/en-us/office/privacy-levels-power-query-cc3ede4d-359e-4b28-bc72-9bee7900b540
cu
Chris

Sub bereich_kopieren() Dim strPfad As String, strBlatt As String Dim wsZiel As Worksheet Dim wbQuelle As Workbook Dim wsQuelle As Worksheet Application.ScreenUpdating = False strPfad = ThisWorkbook.Path & "\ImportFile for Outlook by Manager.xlsx" strBlatt = Range("G2") 'Zielblatt = aktive Datei, aktives Blatt Set wsZiel = ActiveWorkbook.ActiveSheet 'Quellblatt = Datei, Blatt 1 Set wbQuelle = Workbooks.Open(strPfad) Set wsQuelle = wbQuelle.Worksheets(strBlatt) wsQuelle.Cells.Copy Destination:=wsZiel.Cells 'Quelle schließen wbQuelle.Close False Set wsQuelle = Nothing Set wsZiel = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Import aus Excel-File bis Zeile leer ist

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread