Bulk Exportieren von Bildern aus Excel-Zellen-Datei mit VBA

Question

Ich habe zwei Spalten in Excel-Blatt.

Zellen in Spalte A haben Bildnamen und Zellen in Spalte B haben Bild.

Ich bin auf der Suche nach einer VBA-Lösung, um Bilder nacheinander in einen Ordner mit gegebenem Dateinamen in den gleichen Zeilen zu exportieren.

Answer 1

Ich denke, dass ich Ihnen vor ein paar Tagen mit einer sehr ähnlichen Frage geholfen haben könnte. So importieren Sie Bilder.

Sub InsertPics() 
Dim fPath As String, fName As String 
Dim r As Range, rng As Range 

Application.ScreenUpdating = False 
fPath = "C:\Users\Public\Pictures\Sample Pictures\" 
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 
i = 1 

For Each r In rng 
    fName = Dir(fPath) 
    Do While fName <> "" 
     If fName = r.Value Then 
      With ActiveSheet.Pictures.Insert(fPath & fName) 
       .ShapeRange.LockAspectRatio = msoTrue 
       Set px = .ShapeRange 
       If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width 
        With Cells(i, 2) 
         px.Top = .Top 
         px.Left = .Left 
         .RowHeight = px.Height 
        End With 
      End With 
     End If 
     fName = Dir 
    Loop 
    i = i + 1 
Next r 
Application.ScreenUpdating = True 
End Sub 

‚Hinweis: Sie müssen die Dateierweiterung, wie‘, jpg‘, oder was auch immer Sie verwenden, damit Sie sich auf die mithalten können.

Dies ist, wie Sie Bilder bewegen (oder irgendeine Art von Dateien)

Kopieren oder Verschieben einer Datei

For one file you can use the VBA Name and FileCopy function and for entire folders or a lot of files use the other macro example's on this page. 

Sub Copy_One_File() 
    FileCopy "C:\Users\Ron\SourceFolder\Test.xls", "C:\Users\Ron\DestFolder\Test.xls" 
End Sub 

Sub Move_Rename_One_File() 
'You can change the path and file name 
    Name "C:\Users\Ron\SourceFolder\Test.xls" As "C:\Users\Ron\DestFolder\TestNew.xls" 
End Sub 

Kopieren oder mehrere Dateien oder komplette Ordner verschieben

Note: Read the commented code lines in the code 

Sub Copy_Folder() 
'This example copy all files and subfolders from FromPath to ToPath. 
'Note: If ToPath already exist it will overwrite existing files in this folder 
'if ToPath not exist it will be made for you. 
    Dim FSO As Object 
    Dim FromPath As String 
    Dim ToPath As String 

    FromPath = "C:\Users\Ron\Data" '<< Change 
    ToPath = "C:\Users\Ron\Test" '<< Change 

    'If you want to create a backup of your folder every time you run this macro 
    'you can create a unique folder with a Date/Time stamp. 
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss") 

    If Right(FromPath, 1) = "\" Then 
     FromPath = Left(FromPath, Len(FromPath) - 1) 
    End If 

    If Right(ToPath, 1) = "\" Then 
     ToPath = Left(ToPath, Len(ToPath) - 1) 
    End If 

    Set FSO = CreateObject("scripting.filesystemobject") 

    If FSO.FolderExists(FromPath) = False Then 
     MsgBox FromPath & " doesn't exist" 
     Exit Sub 
    End If 

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath 
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath 

End Sub 


Sub Move_Rename_Folder() 
'This example move the folder from FromPath to ToPath. 
    Dim FSO As Object 
    Dim FromPath As String 
    Dim ToPath As String 

    FromPath = "C:\Users\Ron\Data" '<< Change 
    ToPath = "C:\Users\Ron\Test" '<< Change 
    'Note: It is not possible to use a folder that exist in ToPath 

    If Right(FromPath, 1) = "\" Then 
     FromPath = Left(FromPath, Len(FromPath) - 1) 
    End If 

    If Right(ToPath, 1) = "\" Then 
     ToPath = Left(ToPath, Len(ToPath) - 1) 
    End If 

    Set FSO = CreateObject("scripting.filesystemobject") 

    If FSO.FolderExists(FromPath) = False Then 
     MsgBox FromPath & " doesn't exist" 
     Exit Sub 
    End If 

    If FSO.FolderExists(ToPath) = True Then 
     MsgBox ToPath & " exist, not possible to move to a existing folder" 
     Exit Sub 
    End If 

    FSO.MoveFolder Source:=FromPath, Destination:=ToPath 
    MsgBox "The folder is moved from " & FromPath & " to " & ToPath 

End Sub 


Sub Copy_Files_Dates() 
'This example copy all files between certain dates from FromPath to ToPath. 
'You can also use this to copy the files from the last ? days 
'If Fdate >= Date - 30 Then 
'Note: If the files in ToPath already exist it will overwrite 
'existing files in this folder 
    Dim FSO As Object 
    Dim FromPath As String 
    Dim ToPath As String 
    Dim Fdate As Date 
    Dim FileInFromFolder As Object 

    FromPath = "C:\Users\Ron\Data" '<< Change 
    ToPath = "C:\Users\Ron\Test" '<< Change 

    If Right(FromPath, 1) <> "\" Then 
     FromPath = FromPath & "\" 
    End If 

    If Right(ToPath, 1) <> "\" Then 
     ToPath = ToPath & "\" 
    End If 

    Set FSO = CreateObject("scripting.filesystemobject") 

    If FSO.FolderExists(FromPath) = False Then 
     MsgBox FromPath & " doesn't exist" 
     Exit Sub 
    End If 

    If FSO.FolderExists(ToPath) = False Then 
     MsgBox ToPath & " doesn't exist" 
     Exit Sub 
    End If 

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files 
     Fdate = Int(FileInFromFolder.DateLastModified) 
     'Copy files from 1-Oct-2006 to 1-Nov-2006 
     If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then 
      FileInFromFolder.Copy ToPath 
     End If 
    Next FileInFromFolder 

    MsgBox "You can find the files from " & FromPath & " in " & ToPath 

End Sub 


Sub Copy_Certain_Files_In_Folder() 
'This example copy all Excel files from FromPath to ToPath. 
'Note: If the files in ToPath already exist it will overwrite 
'existing files in this folder 
    Dim FSO As Object 
    Dim FromPath As String 
    Dim ToPath As String 
    Dim FileExt As String 

    FromPath = "C:\Users\Ron\Data" '<< Change 
    ToPath = "C:\Users\Ron\Test" '<< Change 

    FileExt = "*.xl*" '<< Change 
    'You can use *.* for all files or *.doc for Word files 

    If Right(FromPath, 1) <> "\" Then 
     FromPath = FromPath & "\" 
    End If 

    Set FSO = CreateObject("scripting.filesystemobject") 

    If FSO.FolderExists(FromPath) = False Then 
     MsgBox FromPath & " doesn't exist" 
     Exit Sub 
    End If 

    If FSO.FolderExists(ToPath) = False Then 
     MsgBox ToPath & " doesn't exist" 
     Exit Sub 
    End If 

    FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath 
    MsgBox "You can find the files from " & FromPath & " in " & ToPath 

End Sub 


Sub Move_Certain_Files_To_New_Folder() 
'This example move all Excel files from FromPath to ToPath. 
'Note: It will create the folder ToPath for you with a date-time stamp 
    Dim FSO As Object 
    Dim FromPath As String 
    Dim ToPath As String 
    Dim FileExt As String 
    Dim FNames As String 

    FromPath = "C:\Users\Ron\Data" '<< Change 
    ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss") _ 
      & " Excel Files" & "\" '<< Change only the destination folder 

    FileExt = "*.xl*" '<< Change 
    'You can use *.* for all files or *.doc for word files 

    If Right(FromPath, 1) <> "\" Then 
     FromPath = FromPath & "\" 
    End If 

    FNames = Dir(FromPath & FileExt) 
    If Len(FNames) = 0 Then 
     MsgBox "No files in " & FromPath 
     Exit Sub 
    End If 

    Set FSO = CreateObject("scripting.filesystemobject") 

    FSO.CreateFolder (ToPath) 

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath 
    MsgBox "You can find the files from " & FromPath & " in " & ToPath 

End Sub