VBA - Image File Name Processing - Change file name, then move to another sheet

[Timkay]

I'm currently trying to write a VBA script for image processing purposes, to accurately change the title of an image file to contain all our required details. We currently have images created as a standard Reference IMG0001, IMG0002, onwards, which would be manually input into column A, and the idea is to fill out columns C:L with information, this is compiled into Column B into one string, which is the required title. I currently have a VBA script which works to do the changing name part, which is as below:

Sub RenameFiles()
Dim sFolder As String
sFolder = ActiveWorkbook.Path & "\"
    Dim m As Long
    Dim v As Variant
    m = Range("A" & Rows.Count).End(xlUp).Row
    v = Range("A1:B" & m).Value
    On Error GoTo ErrHandler
    For r = 2 To m
        Name sFolder & v(r, 1) & ".JPG" As sFolder & v(r, 2)
    Next r
    Exit Sub
ErrHandler:
    MsgBox "Failed to rename " & v(r, 1), vbInformation
    Resume Next
        Exit Sub
End Sub

Although what I am looking to add is that each time there is a successful title change, that entire row is then copied across as values to the neighbouring worksheet titled "Image Details" in the next non-empty row (Column C must be filled in for each image if that wants to be used to reference the next non-empty row), and then the contents to be removed from said row (except for column B's values as this is a formula), I'd also be happy for the entire row to be deleted if that were more convenient.

Any help and suggestions would be much appreciated. I've tried finding a process myself, although have unfortunately been unable to create anything that works!

 

[Timkay]

If anyone has any suggestions for a different process to get this sorted, that would also be greatly appreciated!

 

[NdNoviceHlp]

You will have to start by further explaining your picture file input. Are they images on the sheet or file locations? Why are you manually inputting each pic? is the neighboring ws in the same wb? Doesn't deleting the entire row remove the "B" formula too?" HTH. Dave

 

[Timkay]

Hi Dave, thank you for your response. Will answer all as below:
Are the images on the sheet or file locations? - The images are all files in the same folder location as where the spreadsheet is
Why are you manually inputting each pic? - Manual input for each image is due to us needing to add information to contextualise what was captured, as well as adding different parameters (all captured in columns C:L).
Is the neighboring ws in the same wb? It's in the same workbook
Doesn't deleting the entire row remove the "B" formula too? Yes it would, ideally it would be the removal of all the copied across values in columns A and C:L, although if it would work better to just remove row B, I could manually extend the formula down to cell 1000, which would last us a very long time, and intermittently repeat that process as required.
Hopefully that all makes sense, although if anything isn't clear, let me know and I'll try and better describe it. Thank you for your time on this!

 

[NdNoviceHlp]

You may need to post a wb as I'm still not that clear on all that you need to achieve. You can trial this. Please back up your wb before testing. This untested code should transfer your row data (A-L) to the image details sheet. You will need to adjust the originating sheet name to suit. Dave

Sub RenameFiles()
Dim sFolder As String, LastR As Long, Rng As Range, ws As Worksheet
sFolder = ActiveWorkbook.Path & "\"
    Dim m As Long, r As Integer
    Dim v As Variant
    '***change sheet name to suit
    Set ws = ThisWorkbook.Sheets("Sheet1")
    m = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    v = ws.Range("A1:B" & m).Value
    On Error GoTo ErrHandler
    For r = 2 To m
        Name sFolder & v(r, 1) & ".JPG" As sFolder & v(r, 2)
        With ws ' not sure about columns to transfer?
        Set Rng = .Range(.Cells(r, "A"), .Cells(r, "L"))
        End With
        'move row data to image details sht (A-L)
        With Sheets("Image Details")
        LastR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Cells(LastR, "A").Resize(Rng.Rows.Count, _
            Rng.Columns.Count).Cells.Value = Rng.Cells.Value
        End With
    Next r
    Exit Sub
ErrHandler:
    MsgBox "Failed to rename " & v(r, 1), vbInformation
    Resume Next
        Exit Sub
End Sub

 

[Timkay]

Hi Dave,

My apologies for not having replied earlier to this. The proposed code you linked works great for moving across the details, so that's very much appreciated!

Would it be possible to have the error handler work for moving across details as well, so if an entry is not renamed, it wouldn't move across said row of data?

Then finally upon successful moving of the image across can the details all be removed from the original "File Changing" sheet?

I've taken screenshots of a test version of the spreadsheet, which hopefully makes sense with the content therein?

 

[NdNoviceHlp]

Hi Timkay. You can give this a whirl. Please save a copy of your wb first. Dave

Sub test()
'***change sheet name to suit
    Set ws = ThisWorkbook.Sheets("Sheet1")
    m = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    v = ws.Range("A1:B" & m).Value
    On Error GoTo ErrHandler
    For r = 2 To m
        Name sFolder & v(r, 1) & ".JPG" As sFolder & v(r, 2)
        With ws ' not sure about columns to transfer?
        Set Rng = .Range(.Cells(r, "A"), .Cells(r, "L"))
        End With
        'move row data to image details sht (A-L)
        With Sheets("Image Details")
        LastR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Cells(LastR, "A").Resize(Rng.Rows.Count, _
            Rng.Columns.Count).Cells.Value = Rng.Cells.Value
        End With
    Rng.ClearContents
    Next r
    Exit Sub
ErrHandler:
    MsgBox "Failed to rename " & v(r, 1), vbInformation
    With ws ' not sure about columns to transfer?
    Set Rng = .Range(.Cells(r, "A"), .Cells(r, "L"))
    End With
    With Sheets("Image Details")
    LastR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Cells(LastR, "A").Resize(Rng.Rows.Count, _
    Rng.Columns.Count).Cells.Value = Rng.Cells.Value
    End With
    Rng.ClearContents
    Resume Next
        Exit Sub
End Sub

 

[Timkay]

Hi Dave, you are brilliant! Thank you for helping sort this, you've been a massive help, as I have been stuck on trying to get this sorted for quite a while until you started helping. To complete the code with some minor changes mainly relating to error handling, I'm going to post the final code below for posterity purposes, should anyone ever require a similar solution.

Sub RenameFiles()
Dim sFolder As String, LastR As Long, Rng As Range, ws As Worksheet
sFolder = ActiveWorkbook.Path & "\"
    Dim m As Long, r As Integer
    Dim v As Variant
    Set ws = ThisWorkbook.Sheets("File Changing")
    m = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    v = ws.Range("A1:B" & m).Value
    On Error GoTo ErrHandler
    For r = 2 To m
        Name sFolder & v(r, 1) & ".JPG" As sFolder & v(r, 2)
        With ws
        Set Rng = .Range(.Cells(r, "A"), .Cells(r, "L"))
        End With
        'move row data to image details sht (A-L)
        With Sheets("Image Details")
        LastR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Cells(LastR, "A").Resize(Rng.Rows.Count, _
            Rng.Columns.Count).Cells.Value = Rng.Cells.Value
        End With
        Rng.SpecialCells(xlCellTypeConstants, 23).ClearContents
    Next r
    Exit Sub
ErrHandler:
    MsgBox "Failed to rename " & v(r, 1), vbInformation
    'the below part removes empty rows up until the one with an error, which means when error is resolved, the name changing code will work again.
    Dim fr As Long
With Sheets("File Changing").Range("A:L")
   fr = .Find(what:="*", after:=.Cells(3, 2), LookIn:=xlValues).Row
   If fr > 2 Then
       .Rows("2:" & fr - 1).Delete
   End If
End With
        Exit Sub
End Sub

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome and have a safe and happy holiday season. Dave