[VBA] verschieben einer Datei

[Rabe]

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 

[atilla]

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

[snb]

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

[Rabe]

Hi Atilla,

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

der Code kopiert aber nur, der verschiebt nicht!

[Rabe]

Hi,

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)) 


[snb]

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

[Rabe]

Hi,

jetzt sagt der Computer in dieser Zeile:

  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!

[snb]

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

[Rabe]

Hi,

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

[snb]

Statt

Code:

workbooks.open(.selecteditems(1))

verwende

Code:

with getobject(.selecteditems(1))

  .close 0
end with