Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA - Workbook verschieben
#1
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
Antwortento top
#2
Hi

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

Gruß Elex
Antwortento top
#3
(24.03.2020, 09:49)Elex schrieb: 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ß
Antwortento top
#4
Hi

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

Zitat: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
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste