VBA - Workbook verschieben

[Papierkrieger]

Hallo liebe Excel Freunde,

mit folgendem Code habe ich momentan eine Datenbank, die ich fütter:

Code:

Const Pfad As String = "WerteQuelle" '<<< anpassen

Sub F_en_V2()

Dim WBQ As Workbook
Dim WQ As Worksheet
Dim WZ As Worksheet
Dim RNG As Range, SP1 As Range, SP2 As Range

Set WZ = Sheets(1)                     '<<<< prüfen (Sheet2 der Beispieldatei)
lr = WZ.Cells(Rows.Count, 1).End(xlUp).Row

f = Dir(Pfad & "*.xlsx") 

Do While Len(f)
    Set WBQ = Workbooks.Open(Pfad & f)
   
    Set WQ = WBQ.Sheets(1)
     
    With WQ.Columns(1)
        .UnMerge
        Set RNG = .Find("*Suchbegriff:", , xlValues, xlWhole)
        If Not RNG Is Nothing Then
            Adr = RNG.Address
            Do
               lr = lr + 1 
               WZ.Cells(lr, 2) = .Cells(2, 1)
               WZ.Cells(lr, 4) = .Cells(3, 1)
               WZ.Cells(lr, 5) = .Cells(6, 1)
               WZ.Cells(lr, 6) = .Cells(7, 1)
               WZ.Cells(lr, 7) = .Cells(8, 1)
               WZ.Cells(lr, 8) = .Cells(9, 1)
               WZ.Cells(lr, 9) = .Cells(10, 1)
               WZ.Cells(lr, 10) = .Cells(11, 1)
               WZ.Cells(lr, 11) = .Cells(12, 1)
               
               ' lr = lr + 1
               ' WZ.Cells(lr, 1) = .Find("Laserzeit", , xlValues, xlWhole)
               
               Set SP1 = RNG.End(xlToRight)
                   
                    SP1.Resize(8).Copy
                    WZ.Cells(lr, 13).PasteSpecial Transpose:=True
                   
               Set SP2 = SP1.End(xlToRight).End(xlToRight)
                    SP2.Resize(5).Copy
                    WZ.Cells(lr, "u").PasteSpecial Transpose:=True
                   
            Set RNG = .FindNext(RNG)
            Loop Until RNG.Address = Adr
        End If
    End With
   

    ' WBQ Move to "Zielordern" Somehow

    WBQ.Close 0

   

f = Dir
Loop
End Sub

Nun möchte ich jedes Workbook, dass er öffnet automatisch in ein bestimmtes Verzeichnis verschieben.

Wie löse ich das am geschicktesten?

Lieben Gruß und vielen Dank für die Mühen vorab :19:

[Elex]

Hi

schau mal ob dir der Ansatz hier reicht.
https://www.herber.de/forum/archiv/1524t...ieben.html

Gruß Elex

[Papierkrieger]

Hi

schau mal ob dir der Ansatz hier reicht.
https://www.herber.de/forum/archiv/1524t...ieben.html

Gruß Elex

Hi, den habe ich auch schon gefunden, es aber nicht geschafft ihn in meinen Code einzubasteln, damit es funktioniert.

Ich bin eher ein VBA Leihe und tue mich etwas schwer damit eine Syntax umzuschreiben. Hast du denn ggf. eine Idee, wie dieser Ansatz auf meinen Anwendungsfall passt?

Gruß

[Elex]

Hi

Schwierig ohne Testmöglichkeit und Kenntnis aller Hintergründe.

in ein bestimmtes Verzeichnis verschieben

Was heißt das. Immer in das Selbe oder wechselt das Verzeichnis.


evtl. so in diese Richtung.

Code:

Const Pfad As String = "WerteQuelle" '<<< anpassen

Sub F_en_V2()

Dim WBQ As Workbook
Dim WQ As Worksheet
Dim WZ As Worksheet
Dim RNG As Range, SP1 As Range, SP2 As Range
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

Set WZ = Sheets(1)                     '<<<< prüfen (Sheet2 der Beispieldatei)
lr = WZ.Cells(Rows.Count, 1).End(xlUp).Row

f = Dir(Pfad & "*.xlsx")

Do While Len(f)
    Set WBQ = Workbooks.Open(Pfad & f)
  
    Set WQ = WBQ.Sheets(1)
    
    With WQ.Columns(1)
        .UnMerge
        Set RNG = .Find("*Suchbegriff:", , xlValues, xlWhole)
        If Not RNG Is Nothing Then
            Adr = RNG.Address
            Do
               lr = lr + 1
               WZ.Cells(lr, 2) = .Cells(2, 1)
               WZ.Cells(lr, 4) = .Cells(3, 1)
               WZ.Cells(lr, 5) = .Cells(6, 1)
               WZ.Cells(lr, 6) = .Cells(7, 1)
               WZ.Cells(lr, 7) = .Cells(8, 1)
               WZ.Cells(lr, 8) = .Cells(9, 1)
               WZ.Cells(lr, 9) = .Cells(10, 1)
               WZ.Cells(lr, 10) = .Cells(11, 1)
               WZ.Cells(lr, 11) = .Cells(12, 1)
              
               ' lr = lr + 1
               ' WZ.Cells(lr, 1) = .Find("Laserzeit", , xlValues, xlWhole)
              
               Set SP1 = RNG.End(xlToRight)
                  
                    SP1.Resize(8).Copy
                    WZ.Cells(lr, 13).PasteSpecial Transpose:=True
                  
               Set SP2 = SP1.End(xlToRight).End(xlToRight)
                    SP2.Resize(5).Copy
                    WZ.Cells(lr, "u").PasteSpecial Transpose:=True
                  
            Set RNG = .FindNext(RNG)
            Loop Until RNG.Address = Adr
        End If
    End With

    WBQ.Close 0

' WBQ Move to "Zielordern" Somehow
   fso.MoveFile Quelle, Ziel

f = Dir
Loop
Set fso = Nothing
End Sub

Gruß Elex