• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Save files based on Cell value

uday

Member
Hi,

Hope you guys are doing well!!

I need a macro that will open a file from downloaded folder one by one (Loop) and save it based on Cell A1 value. Like, in the downloaded folder if the first file has cell value A then it will save the file as A in the A folder and B in a B folder. Basically, the macro needs to allocated and rename the file based on the cell value.

Please see the attached zipped file for your ready reference.

Regards,
Uday
 

Attachments

  • Test.zip
    34.1 KB · Views: 3
Possibly...
Code:
Sub Save_Files_Based_on_Cell_Value()

    '!!! Be aware the FileCopy method will overwrite an existing file with the same name !!!
    
    Dim sPath As String, s As String
    Dim v As Variant, f As Variant
    
    Application.ScreenUpdating = False
    sPath = Environ$("UserProfile") & "\Downloads\Test\"
    v = GetFiles(sPath & "Downloaded\")
    For Each f In v
        With Workbooks.Open(sPath & "Downloaded\" & f, ReadOnly:=True)
            s = .Worksheets(1).Cells(1, 1).Value
            .Close
        End With
        If Not Dir(sPath & s, vbDirectory) = vbNullString Then
            FileCopy sPath & "Downloaded\" & f, sPath & s & "\" & f
        End If
    Next f
    Application.ScreenUpdating = True
End Sub

Function GetFiles(sPath As String) As Variant
    Dim sFileName As String
    With CreateObject("Scripting.Dictionary")
        sFileName = Dir(sPath, vbNormal)
        Do While Not sFileName = vbNullString
            .Item(sFileName) = Empty
            sFileName = Dir
        Loop
        GetFiles = .keys
    End With
End Function
 
Hi RDAngelo,

Thanks for your help! and Time

The Macro is working fine but it is not saving the file into the Downloaded folder with the naming convention mentioned in Cell value A1. Like, if the file's Cell A1 value is "A" then it should save as the file as "A" not 1,2,3....etc.

Do let me know if you need any other information.

Regards,
Uday
 
Try this, but remember that because some of your test files have the same value in A1, some file will be overwritten.
Code:
Option Explicit

Sub Save_Files_Based_on_Cell_Value()

    '!!! Be aware the FileCopy method will overwrite an existing file with the same name !!!
    
    Dim sPath As String, s As String
    Dim v As Variant, f As Variant
    
    Application.ScreenUpdating = False
    sPath = Environ$("UserProfile") & "\Downloads\Test\"
    v = GetFiles(sPath & "Downloaded\")
    For Each f In v
        With Workbooks.Open(sPath & "Downloaded\" & f, ReadOnly:=True)
            s = .Worksheets(1).Cells(1, 1).Value
            .Close
        End With
        If Not Dir(sPath & s, vbDirectory) = vbNullString Then
            FileCopy sPath & "Downloaded\" & f, sPath & s & "\" & s & ".xlsx"
        End If
    Next f
    Application.ScreenUpdating = True
End Sub

Function GetFiles(sPath As String) As Variant
    Dim sFileName As String
    With CreateObject("Scripting.Dictionary")
        sFileName = Dir(sPath, vbNormal)
        Do While Not sFileName = vbNullString
            .Item(sFileName) = Empty
            sFileName = Dir
        Loop
        GetFiles = .keys
    End With
End Function
 
Thanks!! Working like a charm.

This macro needs one very small change further. This has been realized later. If the cell value is A then the file should be saved as Apple and B as Bat, C as Cat, and D as Dog. Awaiting for your response.

Regards,
Uday
 
Code:
Option Explicit

Sub Save_Files_Based_on_Cell_Value()

    '!!! Be aware the FileCopy method will overwrite an existing file with the same name !!!

    Dim sPath As String, s As String, ss As String
    Dim v As Variant, f As Variant

    Application.ScreenUpdating = False
    sPath = Environ$("UserProfile") & "\Downloads\Test\"
    v = GetFiles(sPath & "Downloaded\")
    For Each f In v
        With Workbooks.Open(sPath & "Downloaded\" & f, ReadOnly:=True)
            s = .Worksheets(1).Cells(1, 1).Value
            .Close
        End With
        If Not Dir(sPath & s, vbDirectory) = vbNullString Then
            Select Case s
                Case "A"
                    ss = "Apple"
                Case "B"
                    ss = "Bat"
                Case "C"
                    ss = "Cat"
                Case "D"
                    ss = "Dog"
            End Select
            FileCopy sPath & "Downloaded\" & f, sPath & s & "\" & ss & ".xlsx"
        End If
    Next f
    Application.ScreenUpdating = True
End Sub

Function GetFiles(sPath As String) As Variant
    Dim sFileName As String
    With CreateObject("Scripting.Dictionary")
        sFileName = Dir(sPath, vbNormal)
        Do While Not sFileName = vbNullString
            .Item(sFileName) = Empty
            sFileName = Dir
        Loop
        GetFiles = .keys
    End With
End Function
 
Back
Top