Clever-Excel-Forum

Hallo,

ich öffne über den Dateiauswahl-Dialog eine Datei zum Importieren.

   With Application.FileDialog(1)
      .InitialFileName = ThisWorkbook.Path & "\Anfrage\*.xlsx"
      If .Show Then Workbooks.Open .SelectedItems(1), notify:=False               'Öffnen der Datei aus dem Pfad 
    End With
   
   If Err > 0 Then Exit Sub   'Exit wenn -keine Datei- gewählt wurde 
   On Error GoTo Fehler
   
   Set wbkZiel = ThisWorkbook
   Set wbkQuelle = ActiveWorkbook

Nun soll diese Datei in das Unterverzeichnis \importiert\ verschoben werden, ohne Veränderung der Inhalte.

Wie geht denn das?
So auf jeden Fall nicht:

   wbkQuelle.SaveAs (wbkQuelle.Path & "\importiert\" & wbkQuelle.Name)
   wbkQuelle.Close SaveChanges:=False     'schließen der importierten Datei 
   wbkQuelle.Kill                         'löschen der importierten Datei

Hallo Ralf,

Unten stehenden Code müsstest du auf deine Bedürfnisse anpassen können

Code:
Public Sub Dateien_verschieben()

    Dim strQuelle As String

    Dim strZiel As String

    Dim objFSO As Object

    strQuelle = "C:\Users\ralf\Desktop\Testordner1\*.xls"

    If Dir(strQuelle) = "" Then MsgBox "Nix da!": Exit Sub

    strZiel = "C:\Users\ralf\Desktop\Testordner1\"

    Set objFSO = CreateObject("Scripting.FileSystemObject"zwinkernder Smilie (ironisch)

    objFSO.copyFile strQuelle, strZiel

    Set objFSO = Nothing

End Sub

Diese Code reicht:

Code:
sub M_snb()

  With Application.FileDialog(1)

      .InitialFileName = ThisWorkbook.Path & "\Anfrage\*.xlsx"

      If .Show Then Name .SelectedItems(1) As thisworkbook.path & "\importiert\" & dir(.SelectedItems(1))

  End With

End Sub

Hi Atilla,

(23.03.2017, 12:29)atilla schrieb: [ -> ]Unten stehenden Code müsstest du auf deine Bedürfnisse anpassen können

der Code kopiert aber nur, der verschiebt nicht!

Hi,

(23.03.2017, 12:41)snb schrieb: [ -> ]Diese Code reicht:

da wird beim Einfügen in das Codefenster diese Zeile rot angezeigt:

PHP-Code:
    If .Show Then Name .SelectedItems(1) As thisworkbook.path & "\importiert\" & dir(.SelectedItems(1)) 

Code:
Sub M_snb()

  With Application.FileDialog(1)

     .InitialFileName = ThisWorkbook.Path & "\Anfrage\*.xlsx"

     If .Show Then c00 = .SelectedItems(1)

  End With

  Name c00 As ThisWorkbook.Path & "\importiert\" & Dir(c00)

End Sub

Hi,

jetzt sagt der Computer in dieser Zeile:

(23.03.2017, 13:22)snb schrieb: [ -> ] Name c00 As ThisWorkbook.Path & "\importiert\" & Dir(c00)

Laufzeitfehler 53
Datei nicht gefunden!

[edit]
Ok, es klappt, da fehlte das "\Anfrage" vor dem "\importiert\"

Danke!

Hast du etwas selektiert ?

Code:
Sub M_snb()

  With Application.FileDialog(1)

     .InitialFileName = ThisWorkbook.Path & "\Anfrage\*.xlsx"

     If .Show Then c00 = .SelectedItems(1)

  End With

  msgbox c00

  if c00<>"" then Name c00 As ThisWorkbook.Path & "\importiert\" & Dir(c00)

End Sub

Hi,

(23.03.2017, 14:21)snb schrieb: [ -> ]Hast du etwas selektiert ?

ja, eine zu importierende Datei.

Aber das ist klar, denn ThisWorkBook ist ja das Workbook, in das die zu öffnende Datei importiert werden soll.
Und diese zu öffnende Datei soll nach erfolgtem Import verschoben werden.

Es klappt jetzt einwandfrei, ich konnte es in mein Makro integrieren. So wird nun aus der Datei die Import-Datei geöffnet, die Daten importiert, dann die Importdatei geschlossen und anschließend verschoben.

Sub Daten_Import(control As IRibbonControl)
   Dim strQuelle As String
   Dim strZiel As String
   Dim strQuellPfad As String
   Dim strZielPfad As String
   
   Application.ScreenUpdating = False
   
   'Daten holen über FileDialog  'GetOpenDatei 
   With Application.FileDialog(1)
      .InitialFileName = ThisWorkbook.Path & "\Anfrage\*.xlsx"
      If .Show Then
         Workbooks.Open .SelectedItems(1), notify:=False                        'Öffnen der Datei aus dem Pfad 
         strQuelle = .SelectedItems(1)
      End If
   End With
   
   '   If Err > 0 Then Exit Sub   'Exit wenn -keine Datei- gewählt wurde 
   On Error GoTo Fehler
   
   'ActiveWorkbook ist immer das aktive 
   'ThisWorkbook ist immer das in dem sich dieses Makro befindet, egal ob aktiv oder im Hintergrund 
   
   Set wbkQuelle = ActiveWorkbook
   '   strQuellPfad = ThisWorkbook.Path & "\Anfrage\*.xlsx" 
   Set wbkZiel = ThisWorkbook
   '   strZielPfad = ThisWorkbook.Path & "\Anfrage\importiert\" 
   
   'kopieren in zwei Blöcken, Events ausschalten wegen Löschung durch Änderung in der Zelle C6 
   Application.EnableEvents = False
   wbkQuelle.Sheets("Eingabe_ELC").Range("K1:K3").Copy
   wbkZiel.Sheets("Eingabe_ELC").Range("K1").PasteSpecial xlPasteAll
   wbkQuelle.Sheets("Eingabe_ELC").Range("B5:K26").Copy
   wbkZiel.Sheets("Eingabe_ELC").Range("B5").PasteSpecial xlPasteAll
   Application.CutCopyMode = False
   Application.EnableEvents = True
   
   wbkQuelle.Close SaveChanges:=False     'schließen der importierten Datei 
   'verschieben der importierten Datei 
   Name strQuelle As ActiveWorkbook.Path & "\Anfrage\importiert\" & Dir(strQuelle)
   
   Set wbkQuelle = Nothing
   Set wbkZiel = Nothing
   
   Range("I7").Select
   Exit Sub
   
Fehler:
   Application.ScreenUpdating = True
   Application.EnableEvents = True

   '**  geöffnete Datei wieder schliessen  ** 
      wbkQuelle.Close SaveChanges:=False
   
   MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
       & "Beschreibung: " & Err.Description _
       , vbCritical, "Fehler"
End Sub

Statt

Code:
workbooks.open(.selecteditems(1))

verwende

Code:
with getobject(.selecteditems(1))

  .close 0

end with

Rabe

atilla

snb

Rabe

Rabe

snb

Rabe

snb

Rabe

snb