PDA

View Full Version : [SOLVED] Any way to make this apply to a larger selection instead of just 1 cell ?



technician12
12-17-2018, 06:38 AM
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
12-23-2018, 07:48 PM
Hi technician12!
The picture is too small to see clearly:(

Paul_Hossler
12-23-2018, 08:04 PM
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
01-06-2019, 11:45 PM
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
01-07-2019, 09:04 AM
OK -- taking a guess




Sub MoveFile()
'Graham Mayor - https://www.gmayor.com (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
01-07-2019, 11:19 PM
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
01-08-2019, 08:10 AM
OK -- guessing again

Try changing the line to





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

technician12
01-08-2019, 10:40 PM
Works, Thanks.