Any way to make this apply to a larger selection instead of just 1 cell ?

[technician12]

Hello.

anyone here willing to assist me with changing a formula to apply to more than 1 cell.
see picture for more understanding.

i know i can repeat this formula in a new module for every line ( but i also know this is a very inefficient way of doing it )

:

Sub MoveFile()
'Graham Mayor - https://www.gmayor.com - Last updated - 30 Nov 2018
Dim fso As Object
Dim iPath As Long
Dim vPath As Variant
Dim strPath As String, strOldPath As String
Dim strName As String
Dim xlSheet As Worksheet
    Set xlSheet = ActiveSheet
    With xlSheet
        strPath = .Range("B7") & "\Approved"    'assign the target path to a string
        If UCase(.Range("I3")) = "YES" Then    'check if the move is approved
            Set fso = CreateObject("Scripting.FileSystemObject")
            strOldPath = .Range("E3")    'assign the original file path to a string
            If fso.FileExists(strOldPath) Then
                'extract the filename from the full name
                strName = Split(strOldPath, "")(UBound(Split(strOldPath, "")))
                'ensure the target path exists and create it if it doesn't
                vPath = Split(strPath, "")
                strPath = vPath(0) & ""
                For iPath = 1 To UBound(vPath)
                    strPath = strPath & vPath(iPath) & ""
                    If Not fso.FolderExists(strPath) Then MkDir strPath
                Next iPath
                'move the file
                Name strOldPath As strPath & strName
                Beep
                MsgBox "File moved to " & strPath
            Else
                Beep
                MsgBox strOldPath & " not found"
            End If
        End If
    End With
    Set xlSheet = Nothing
    Set fso = Nothing
    
        Range("I3").Select
    ActiveWindow.SmallScroll Down:=27
    Range("I3:I61").Select
    ActiveWindow.SmallScroll Down:=-39
    Selection.ClearContents
    Range("A1").Select
    
        Range("B7").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
End Sub

:

[大灰狼1976]

Hi technician12!
The picture is too small to see clearly

[Paul_Hossler]

and I added CODE tags to your macro -- you can use the [#] icon to add them and paste your macro between them

There's a lot of recorder stuff (.SmallScroll and .Select, etc.) that are not needed

You mention applying a formula to more that just a single cell, but I don't see a formula in your macro so I'm guessing you meant something else

I don't understand what the 'more than one cell' would be (like all cells in col D that have data for example??).

If you could remove any lines that are not needed to show the issue, that would help to isolate

Also an sample workbook with the macro and some data would be helpful

[technician12]

Sadly i cannot link a workbook.
the problem put simply, this is a macro to move cells in col "I3" to path specified in "B7"+ & \Approved"
i would like all cells between "I3" and "I100" to do the same as "I3" does now.

[Paul_Hossler]

OK -- taking a guess

Sub MoveFile()
'Graham Mayor - 
https://www.gmayor.com
 - Last updated - 30 Nov 2018
Dim fso As Object
Dim iPath As Long
Dim vPath As Variant
Dim strPath As String, strOldPath As String
Dim strName As String
Dim xlSheet As Worksheet


Dim c as range 


    Set xlSheet = ActiveSheet
    With xlSheet
        strPath = .Range("B7") & "\Approved"    'assign the target path to a string

        For Each C in .Range("I3:I100").Cells

           If UCase(C.Value) = "YES" Then    'check if the move is approved
               Set fso = CreateObject("Scripting.FileSystemObject")
               strOldPath = .Range("E3")    'assign the original file path to a string
               If fso.FileExists(strOldPath) Then
                   'extract the filename from the full name
                   strName = Split(strOldPath, "")(UBound(Split(strOldPath, "")))
                   'ensure the target path exists and create it if it doesn't
                   vPath = Split(strPath, "")
                   strPath = vPath(0) & ""
                   For iPath = 1 To UBound(vPath)
                       strPath = strPath & vPath(iPath) & ""
                       If Not fso.FolderExists(strPath) Then MkDir strPath
                   Next iPath
                   'move the file
                   Name strOldPath As strPath & strName
                   Beep
                   MsgBox "File moved to " & strPath
               Else
                   Beep
                   MsgBox strOldPath & " not found"
               End If
           End If
         Next

    End With
    Set xlSheet = Nothing
    Set fso = Nothing
    
    Range("I3:I61").ClearContents
    Range("A1").Select
    
    Range("B7").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
End Sub

[technician12]

Runtime error '53':
File not found

its ment to be a tool for approving documents and moving them to an "approved" folder ( and creating it, if it does not exist ) this macro is simply to move the file from the "E colum" if the corrosponding Cell in the "I colum" states "Yes".

Example:
I3, I7 and I12 states yes
the files in E3, I7 and I12 gets moved to "B7 & \Approved" ( or create folder if it does not exist, and then move file to it ).

[Paul_Hossler]

OK -- guessing again

Try changing the line to

 strOldPath = C.EntireRow.Cells(5).Value     'assign the original file path to a string

[technician12]

Works, Thanks.