Note: The other languages of the website are Google-translated. Back to English

Jak kopírovat nebo přesouvat soubory z jedné složky do druhé na základě seznamu v aplikaci Excel? 

Pokud máte seznam názvů souborů ve sloupci v listu a soubory se nacházejí ve složce ve vašem počítači. Ale teď musíte přesunout nebo zkopírovat tyto soubory, jejichž názvy jsou uvedeny v listu z jejich původní složky do jiné, jak je znázorněno na následujícím obrázku. Jak byste mohli tento úkol dokončit co nejrychleji v aplikaci Excel?

Zkopírujte nebo přesuňte soubory z jedné složky do druhé na základě seznamu v aplikaci Excel pomocí kódu VBA


Zkopírujte nebo přesuňte soubory z jedné složky do druhé na základě seznamu v aplikaci Excel pomocí kódu VBA

Chcete-li přesunout soubory z jedné složky do druhé na základě seznamu názvů souborů, následující kód VBA vám může udělat laskavost, udělejte to takto:

1. Podržte Alt + F11 klíče v aplikaci Excel a otevře Microsoft Visual Basic pro aplikace okno.

2, klikněte Vložit > Modula vložte následující kód VBA do okna modulu.

Kód VBA: Přesuňte soubory z jedné složky do druhé na základě seznamu v aplikaci Excel

Sub movefiles()
'Updateby Extendoffice
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = " Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = " Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
            Kill xSPathStr & xVal
        End If
    Next
End Sub

3. A pak stiskněte F5 klíč ke spuštění tohoto kódu a zobrazí se výzva, která vám připomene výběr buněk, které obsahují názvy souborů, viz screenshot:

4. Pak klikněte na tlačítko OK Tlačítko a ve vyskakovacím okně vyberte složku obsahující soubory, ze kterých se chcete přesunout, viz screenshot:

5. A pak klikněte na tlačítko OK, pokračujte výběrem cílové složky, kam chcete soubory najít, v dalším vyskakovacím okně, viz screenshot:

6. Nakonec klepněte na tlačítko OK zavřete okno a nyní byly soubory přesunuty do jiné složky, kterou jste zadali na základě názvů souborů v seznamu listů, viz screenshot:

Poznámka: Pokud chcete pouze zkopírovat soubory do jiné složky, ale zachovat původní soubory, použijte následující kód VBA:

Kód VBA: Kopírování souborů z jedné složky do druhé na základě seznamu v aplikaci Excel

Sub copyfiles()
'Updateby Extendoffice
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
        End If
    Next
End Sub

 


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
officetab dno

 

Komentáře (73)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
Je to pěkné makro. Skutečně mi pomáhá. ale potřebuji nějaké aktualizační makro. Toto se používá ke kopírování souborů z jedné složky do jiné složky. potřebujeme zkopírovat soubory ze složky a podsložky do jiné složky.
Tento komentář byl moderátorem webu minimalizován
Ahoj, ve zdrojové složce bych ji chtěl nastavit jako konstantu z buňky, například cesta zadaná v konkrétní buňce, jako je A1, by měla být považována za zdrojovou složku. Jak to udělat?
Tento komentář byl moderátorem webu minimalizován
Era exatamente isso que eu precisava!!!

Muito Obrigado!!!!
Tento komentář byl moderátorem webu minimalizován
Dík!!!!
Tento komentář byl moderátorem webu minimalizován
Você não tem noção de como me ajudou com esse skript... Muito bom!!! Obrigado!!!
Tento komentář byl moderátorem webu minimalizován
Ahoj kluci,

Jak potřebuji změnit '' If TypeName(xVal) = "String" And xVal <> "" Potom '' pro přesun souborů na základě částečného názvu souboru.


Díky předem,
S pozdravem P
Tento komentář byl moderátorem webu minimalizován
Zjistili jste někdy, JAK POUŽÍVAT ČÁSTEČNÝ NÁZEV SOUBORU? Taky to potřebuji...
Jinými slovy, pokud je název souboru v seznamu listů aplikace Excel: OW4234TR_J19031.txt (chtěl bych, aby se podíval pouze na posledních 5 znaků „19031“, což je juliánské datum, a přesunul řadu souborů... cokoliv s Juliánské datum 19031 až 19075.
Tento komentář byl moderátorem webu minimalizován
Také bych požadoval částečnou úpravu názvu souboru vba. Dostal jsi někdy odpověď?
Tento komentář byl moderátorem webu minimalizován
Mám zájem o úplně stejné řešení! Dostal někdo odpověď? Mám seznam P/N ve sloupci a chci kus kódu, který vypadá v nadřazené složce, která má několik podsložek za soubory s názvem uvedeným v seznamu, ale pouze částečně, protože neznám příponu souboru a v mnoha případech pro jeden P/N v seznamu mám několik souborů odlišených existencí přípony, která nemá vždy stejný vzor, ​​jako je xxxx_1, xxxx_2, xxx (1 ), xxxx [1], xxxx- (a ), xxxx_ (b) ...., ale potřebuji zkopírovat do cílové složky všechny instance souborů, které obsahují ve svém názvu P/N. Prosím o pomoc Abych tuto práci neprováděl ručně pro 34078 souborů, které se dnes nacházejí v nadřazené složce a podsložkách
Tento komentář byl moderátorem webu minimalizován
Ahoj,
jak přimět tento kód zkopírovat soubory z podsložek?
Tento komentář byl moderátorem webu minimalizován
Nějaké tipy, jak upravit kód pro přidání široké karty? Mám archiv stovek souborů PDF, které mají 10místná čísla a úroveň revize (XXXXXXXXXX_REVA). Z našeho ERP systému mohu velmi snadno exportovat seznam názvů souborů, ale v seznamu chybí revize a přípona souboru. Existuje způsob, jak přidat zástupné karty do programu, aby se ignorovalo vše, KRAJ 10místné číslo?
Tento komentář byl moderátorem webu minimalizován
Nemohu zprovoznit ani jednu verzi ve Windows 10.


Argggg
Tento komentář byl moderátorem webu minimalizován
en el codigo que copia ¿como puedo colorear el nombre de la lista que no encuentre?
Tento komentář byl moderátorem webu minimalizován
Funguje skvěle - děkuji! Nicméně-->>>Lze to upravit tak, aby používal ČÁSTEČNÝ NÁZEV SOUBORU? Pokud ano, můžete pomoci ukázat jak?
Jinými slovy, pokud je název souboru v seznamu názvů souborů na listu aplikace Excel: OW4234TR_J19031.txt (chtěl bych, aby se podíval pouze na posledních 5 znaků „19031“, což je juliánské datum, a přesunul rozsah souborů... ( cokoliv s juliánským datem od 19092 do 19120) do složky březen. Konečným zastřešujícím úkolem je najít všechny soubory, které mají juliánské datum na březen, a vložit je do složky Fiskální březen "06-Mar", duben do Dubnová složka "07-Apr" a tak dále...takže pak mohou proběhnout fiskální odsouhlasení po měsících.. TIA za jakoukoli pomoc může kdokoli nabídnout urychlení tohoto časově náročného procesu lovu a vybírání. =-)
Tento komentář byl moderátorem webu minimalizován
ahoj, víš jak hledat i v podsložce?
Tento komentář byl moderátorem webu minimalizován
Přišel někdo na to, jak zkopírovat soubory, které se nacházejí ve více podsložkách hlavního adresáře, a vložit je do jiného adresáře? Funguje tato metoda přenosu pouze pro složky na jednotce C? Snažím se zkopírovat soubory z našeho adresáře, který obsahuje více podsložek, kde je uloženo několik souborů umístěných v Microsoft Sharepoint, do složky na mém disku C.

Jakákoliv pomoc by byla velmi ceněna!
Tento komentář byl moderátorem webu minimalizován
díky moc !
Tento komentář byl moderátorem webu minimalizován
buenas noches, alguien sabe que tengo que modificar para que me mueva carpetas y no solo archivos?
Tento komentář byl moderátorem webu minimalizován
Jakákoli aktualizace způsobu vyhledávání ve složce a podsložkách
Tento komentář byl moderátorem webu minimalizován
Ahoj, Nasr,
Chcete-li přesunout soubory ze složky a podsložek na základě hodnot buněk, použijte níže uvedený kód VBA:
Zkuste to prosím, doufám, že vám to pomůže!

Dílčí movefiles()
'Aktualizovat Extendoffice
Dim xRg As Range, xCell As Range
Dim xSFileDlg jako FileDialog, xDFileDlg jako FileDialog
Dim xSPathStr jako varianta, xDPathStr jako varianta
Dim xVal As String
Dim fso As Object, folder1 As Object
' Při chybě Pokračovat dále
Set xRg = Application.InputBox("Vyberte prosím názvy souborů:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
Pokud xRg není nic, pak Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = " Vyberte prosím původní složku:"
Pokud xSFileDlg.Show <> -1 Pak Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
Nastavit xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = " Vyberte cílovou složku:"
Pokud xDFileDlg.Show <> -1 Pak Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
Zavolejte sMoveFiles(xRg, xSPathStr, xDPathStr)
End Sub

Sub sMoveFiles (xRg jako rozsah, xSPathStr jako varianta, xDPathStr jako varianta)
Dim xCell As Range
Dim xVal As String
Dim xFolder jako objekt
Dim fso As Object
Dim xF jako objekt
Dim xStr jako řetězec
Dim xFS jako objekt
Dim xI jako celé číslo
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Pak
MkDir (xDPathStr)
End If
Pro xI = 1 To xRg.Count
Nastavit xCell = xRg.Item(xI)
xVal = xCell.Value
If TypeName(xVal) = "String" And Not (xVal = "") Then
Při chybě GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Zabijte xSPathStr & xVal
End If
End If
E1:
Další xI
On Error Resume Next
Nastavit fso = CreateObject ("Scripting.FileSystemObject")
Nastavit xFS = fso.GetFolder(xSPathStr)
Pro každý xF v xFS.SubFolders
xStr = xDPathStr & "\" & xF.Name ' Nahradit(xF.ShortPath, xSPathStr, xDPathStr)
Zavolejte sMoveFiles(xRg, xF.ShortPath & "\", xStr & "\")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
A (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Potom
RmDir xStr
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
To je perfektní, děkuji
ale co kdybych chtěl pouze zkopírovat soubory, nepřesouvat je pouze z podsložek, aniž bych musel vytvářet podsložky v cílové složce
ie
zdrojová složka X:\\rodič
uvnitř rodiče jsou podsložky test1 (soubor A), test2 (soubor B) a test3 (soubor C)
pak cílová složka je "Y:\\destination" má všechny 3 soubory A, B, C bez podsložek

Děkuji moc
Tento komentář byl moderátorem webu minimalizován
Ahoj Nasr, přišel jsi na to, jak to udělat? Momentálně se dívám na podobnou potřebu.

Kopírování vybraných souborů z různých podsložek do jedné složky
Tento komentář byl moderátorem webu minimalizován
Ahoj Mike
Udělal jsem to ALE nepřímo, takže jsem upravil kód tak, aby kopíroval soubory, ne přesunul je s podsložkou
poté pomocí souboru CMD přesuňte soubor z podsložek do hlavní složky a poté odstraňte prázdnou podsložku
tohle jsem udělal

Dílčí kopie souborů()
'Aktualizovat Extendoffice
Dim xRg As Range, xCell As Range
Dim xSFileDlg jako FileDialog, xDFileDlg jako FileDialog
Dim xSPathStr jako varianta, xDPathStr jako varianta
Dim xVal As String
Dim fso As Object, folder1 As Object
' Při chybě Pokračovat dále
Set xRg = Application.InputBox("Vyberte prosím názvy souborů:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
Pokud xRg není nic, pak Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = " Vyberte prosím původní složku:"
Pokud xSFileDlg.Show <> -1 Pak Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
Nastavit xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = " Vyberte cílovou složku:"
Pokud xDFileDlg.Show <> -1 Pak Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
Volání sCopyFiles(xRg, xSPathStr, xDPathStr)
End Sub

Sub sCopyFiles(xRg jako rozsah, xSPathStr jako varianta, xDPathStr jako varianta)
Dim xCell As Range
Dim xVal As String
Dim xFolder jako objekt
Dim fso As Object
Dim xF jako objekt
Dim xStr jako řetězec
Dim xFS jako objekt
Dim xI jako celé číslo
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Pak
MkDir (xDPathStr)
End If
Pro xI = 1 To xRg.Count
Nastavit xCell = xRg.Item(xI)
xVal = xCell.Value
If TypeName(xVal) = "String" And Not (xVal = "") Then
Při chybě GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
End If
End If
E1:
Další xI
On Error Resume Next
Nastavit fso = CreateObject ("Scripting.FileSystemObject")
Nastavit xFS = fso.GetFolder(xSPathStr)
Pro každý xF v xFS.SubFolders
xStr = xDPathStr & "\" & xF.Name ' Nahradit(xF.ShortPath, xSPathStr, xDPathStr)
Zavolejte sCopyFiles(xRg, xF.ShortPath & "\", xStr & "\")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
A (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Potom
RmDir xStr
End If
další
End Sub



poté zkopírujte následující řádky do nového poznámkového bloku a poté jej uložte jako cmd, nazvěte jej jakkoli

for /r %%a IN (*.*) do (
přesun /y "%%a" "%cd%"
)
for /f "delims=" %%d in ('dir /s /b /ad ^| sort /r') do rd "%%d"



nezapomeňte zkopírovat kód jako 4 řádky
doufám, že to pomůže
Tento komentář byl moderátorem webu minimalizován
ujistěte se, že jste soubor cmd umístili do stejné složky, do které kopírujete soubory a podsložky, a poté na něj dvakrát klikněte
Tento komentář byl moderátorem webu minimalizován
Stejného výsledku můžete dosáhnout pouze s použitím VBA, pokud přidáte ' před & "\" & xF.Name v níže uvedeném řádku.
Toto se stále zkopíruje z podsložek, ale zkopíruje se do složky jedné úrovně.

xStr = xDPathStr & "\" & xF.Name ' Nahradit(xF.ShortPath, xSPathStr, xDPathStr)
Stane se
xStr = xDPathStr '& "\" & xF.Name ' Nahradit(xF.ShortPath, xSPathStr, xDPathStr)
Tento komentář byl moderátorem webu minimalizován
Ahoj skyyang, chci zkopírovat nebo přesunout soubory (.jpg, .png) jakéhokoli formátu ze složky a jejích podsložek. Výše uvedený skript kopíruje celou složku obsahující odpovídající soubor
Díky & Pozdravy,
Tento komentář byl moderátorem webu minimalizován
Ahoj, nejsem odborník na VBA, ale potřebuji váš modul a udělal jsem podle vašich pokynů, ale nic se nezkopírovalo ze zdrojové složky do nové složky. a nezobrazí se žádná chyba
Tento komentář byl moderátorem webu minimalizován
A co se stane, když soubor v původní složce neexistuje?
kód se rozbije

Kód musí mít řádek pro skok na jiný odkaz, pokud neexistuje
Tento komentář byl moderátorem webu minimalizován
Pokud odkaz neexistuje, zalomení kódu
na kterém řádku budu muset kód provést skok přes další odkaz bez zastavení
Tento komentář byl moderátorem webu minimalizován
Jak by to mohlo být upraveno tak, aby bylo možné vložit do seznamu více cest k souboru namísto jedné cesty najednou?
Tento komentář byl moderátorem webu minimalizován
Ahoj sabine,
Chcete zkopírovat a vložit soubory z více původních složek namísto pouze jedné složky?
Tento komentář byl moderátorem webu minimalizován
Ano prosím
Zatím zde nejsou žádné komentáře
Načíst další
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL