Sorting PICTURES once they have been imported into a cell

GaryJ09

New Member
Joined
Jun 11, 2009
Messages
29
Hello, I have inserted pictures into my worksheet with this code:

Code:
Sub InsertPicture()
Dim sPicture As String, pic As Picture
 
sPicture = Application.GetOpenFilename _
    ("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
     , "Select Picture to Import")
 
If sPicture = "False" Then Exit Sub
 
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Height = ActiveCell.Height
    .Width = ActiveCell.Width
    .Top = ActiveCell.Top
    .Left = ActiveCell.Left
    .Placement = xlMoveAndSize
    .ShapeRange.LockAspectRatio = msoTrue
' etc.
End With
 
Set pic = Nothing
 
End Sub
I am having a problem when I try to sort the columns next to the pictures. Please take a look at the picture below:



If I sort the Item Number column, the pictures do not move and stay in their respective cells. Is there any way to change this? Thanks.
 

sykes

Well-known Member
Joined
May 1, 2002
Messages
1,561
This seems to work, but sometimes one of the pictures doesn't follow its cell. You may be better to put some data into each cell behind the picture, so that Excel has something to sort.
the code's a bit "Schoolboy" as I just recorded it with the macro recorder, but I'm sure you can use it to get you going, and adjust to suit.

You could incorporate it into your existing code, so that the sort is completed immediately after inserting a new picture....

Code:
Sub sorter()
'
' sorter Macro
'

'
    Range("A1:D36").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B36"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:D36")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 

GaryJ09

New Member
Joined
Jun 11, 2009
Messages
29
Thanks for the quick reply. I added the code right after the existing code, however same result. I also added data underneath the picture like you suggested.



Here is the complete code now:

Code:
Sub InsertPicture()
Dim sPicture As String, pic As Picture
 
sPicture = Application.GetOpenFilename _
    ("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
     , "Select Picture to Import")
 
If sPicture = "False" Then Exit Sub
 
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Height = ActiveCell.Height
    .Width = ActiveCell.Width
    .Top = ActiveCell.Top
    .Left = ActiveCell.Left
    .Placement = xlMoveAndSize
    .ShapeRange.LockAspectRatio = msoTrue
' etc.
End With
 
Set pic = Nothing
 
End Sub

Sub sorter()
'
' sorter Macro
'

'
    Range("A1:D36").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B36"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:D36")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Any other suggestions? Thanks again for your help.
 

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
The cells needs to contain the picture names, you can then run a macro to put the pictures back into the cells with their names.
 

GaryJ09

New Member
Joined
Jun 11, 2009
Messages
29
The cells do contain the picture names, I set the value of the first column equal to the value in the column "Item Number" (please take a look at the last uploaded picture).

Thanks.
 

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
The name box top left shows "Picture 21" which is the picture name
You are probably thinking of file name which is not the same thing.
No point in re-inserting the file if you have a picture already.
You need to reset the top/left of the pictures to those of the appropriate cells.
 
Last edited:

GaryJ09

New Member
Joined
Jun 11, 2009
Messages
29
I am not familiar with working with the Name Box. Is there an automated way or formula to change the Name Box value to that of the file name so that it will be sorted correctly?

Also, the pictures themselves do not move when I run the sort, they stay locked to their respective cells.
 

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
Needs some extra work to set things up, so here is some code for the whole "package" for setting up & sorting.
Rich (BB code):
'- GET PICTURES FROM A FOLDER INTO A WORKSHEET & FIT TO CELLS
'- With small amendments ADD_NEW_PICTURE subroutine could be made standalone
'- THERE IS A SEPARATE SUBROUTINE SORT THE DATA AND PICTURES
'- NB. Ignores picture properties eg.Move & size with cells etc. which can be set with code
'------------------------------------------------------------------
'- Brian Baulsom May 2010
'- ref some other messages containing similar code :
'- http://www.mrexcel.com/forum/showthread.php?t=311884
'- http://www.mrexcel.com/board2/viewtopic.php?t=145831
'=============================================================================
'- *** NB. Amend code below to
'- *** 1. Set PictureFolder variable
'- *** 2. Set picture file suffix (eg. *.bmp, *.wmf etc.)
'- Run macro from the target worksheet
'=============================================================================
Dim PictureSourceFolder As String
Dim ToBook As String
Dim ToSheet As Worksheet
Dim PictureFname As String
Dim PictureFullname As String
'- SUBROUTINE VARIABLES
Dim PictureCell As Range
Dim ToRow As Long
'==============================================================================
'- MAIN ROUTINE
'==============================================================================
Sub PICTURES_FROM_FOLDER()
    '=====================================================
    '-*** NB SET THIS TO THE CORRECT PICTURE FOLDER ***
    '=====================================================
    PictureSourceFolder = "F:\test\"
    '=====================================================
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ToBook = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    '-------------------------------------------------------------------------
    '- WORKSHEET SETUP
    Set ToSheet = ActiveSheet
    ToRow = 2
    With ToSheet
        .Cells.ClearContents
        .Range("A1:B1").Value = Array("Picture", "Item Number")
        .Columns("A").EntireColumn.ColumnWidth = 20
        .Rows.EntireRow.RowHeight = 60
        '---------------------------------------------------------------------
        '- CLEAR EXISTING PICTURES
        For Each s In .Shapes
            s.Delete
        Next
        '---------------------------------------------------------------------
    End With
    '====================================================
    ' *** NB. AMEND LINE BELOW FOR CORRECT FILE SUFFIX
    PictureFname = Dir(PictureSourceFolder & "*.jpg")
    '===================================================
    '- loop to get each picture file from the folder
    While PictureFname <> ""
        Application.StatusBar = PictureFname
        '---------------
        ADD_NEW_PICTURE         ' CALL SUBROUTINE BELOW
        '---------------
        PictureFname = Dir
    Wend
    '------------------------------------------------------------------------
    SORT_DATA_AND_PICTURES      ' CALL SUBROUTINE BELOW
    '------------------------------------------------------------------------
    '-- close
    Application.ScreenUpdating = True
    Range("A1").Select      ' remove Selection from the picture
    MsgBox ("Done.")
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
End Sub
'======= end of main routine==================================================
 
'=============================================================================
'- SUBROUTINE TO ADD A NEW PICTURE TO A WORKSHEET
'- Column A : Add picture & size to the cell
'-            Name picture as file name(no suffix). Picture name to cell
'- Column B : File Name without suffix
'=============================================================================
Private Sub ADD_NEW_PICTURE()
    Dim ItemName As String
    ItemName = Left(PictureFname, Len(PictureFname) - 4)
    '-------------------------------------------------------------------------
    '- INSERT PICTURE
    PictureFullname = PictureSourceFolder & PictureFname
    ToSheet.Pictures.Insert(PictureFullname).Select
    '-------------------------------------------------------------------------
    '- POSITION PICTURE
    With ToSheet.Cells(ToRow, 1)
        .Value = ItemName
        Selection.Name = ItemName
        Selection.Top = .Top
        Selection.Left = .Left
        Selection.Height = .Height
        Selection.Width = .Width
    End With
    '-------------------------------------------------------------------------
    ToSheet.Cells(ToRow, 2).Value = ItemName
    ToRow = ToRow + 1
End Sub
'=============================================================================
'=============================================================================
'- SORT DATA & PICTURES
'- CALLED FROM ABOVE - BUT THIS ROUTINE CAN BE USED ON ITS OWN
'- assumes that cells and pictures are the same size already
'- ....... and the cells contain the picture names
'=============================================================================
Sub SORT_DATA_AND_PICTURES()
    Dim ws As Worksheet
    Dim rw As Long
    Dim LastRow As Long
    Dim PictureName As String
    '-------------------------------------------------------------------------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set ws = ActiveSheet
    LastRow = ws.Range("A65536").End(xlUp).Row
    '-------------------------------------------------------------------------
    '- SORT DATA
    ws.Range("A1").Sort Key1:=Range("B2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
    '-------------------------------------------------------------------------
    '- PUT PICTURES INTO CORRECT CELLS
    '- assumes that cells and pictures are the same size already
    For rw = 2 To LastRow
        With ws.Cells(rw, 1)
            PictureName = .Value
            ws.Shapes(PictureName).Select
            Selection.Top = .Top
            Selection.Left = .Left
        End With
    Next
    '-------------------------------------------------------------------------
    Application.Calculation = xlCalculationAutomatic
    Range("A1").Select      ' remove Selection from the picture
    Beep
End Sub
'=========== END OF ROUTINE ==================================================
 
Last edited:

GaryJ09

New Member
Joined
Jun 11, 2009
Messages
29
So I've been trying to get this to work, but can't seem to do so. First off, I changed the source directory to where my pictures were held and kept the line for file name suffix at .jpg. Secondly, I had to get rid of the ".Cells.ClearContents" line because running the macro with it would just clear the whole worksheet except A1 and B1. I ran the macro after deleting the line, and it almost worked. The sorting is done correctly, but no pictures were added to the worksheet (column A stays empty). Any ideas?

I attached the code I am running

Code:
'- GET PICTURES FROM A FOLDER INTO A WORKSHEET & FIT TO CELLS
'- With small amendments ADD_NEW_PICTURE subroutine could be made standalone
'- THERE IS A SEPARATE SUBROUTINE SORT THE DATA AND PICTURES
'- NB. Ignores picture properties eg.Move & size with cells etc. which can be set with code
'------------------------------------------------------------------
'- Brian Baulsom May 2010
'- ref some other messages containing similar code :
'- http://www.mrexcel.com/forum/showthread.php?t=311884
'- http://www.mrexcel.com/board2/viewtopic.php?t=145831
'=============================================================================
'- *** NB. Amend code below to
'- *** 1. Set PictureFolder variable
'- *** 2. Set picture file suffix (eg. *.bmp, *.wmf etc.)
'- Run macro from the target worksheet
'=============================================================================
Dim PictureSourceFolder As String
Dim ToBook As String
Dim ToSheet As Worksheet
Dim PictureFname As String
Dim PictureFullname As String
'- SUBROUTINE VARIABLES
Dim PictureCell As Range
Dim ToRow As Long
'==============================================================================
'- MAIN ROUTINE
'==============================================================================
Sub PICTURES_FROM_FOLDER()
    '=====================================================
    '-*** NB SET THIS TO THE CORRECT PICTURE FOLDER ***
    '=====================================================
    PictureSourceFolder = "C:\Users\Gary\Desktop\Website\Kondrotas Photots\New folder"
    '=====================================================
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ToBook = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    '-------------------------------------------------------------------------
    '- WORKSHEET SETUP
    Set ToSheet = ActiveSheet
    ToRow = 2
    With ToSheet
    '    .Cells.ClearContents      *****  IF I LEAVE THIS LINE IN, IT CLEARS THE WHOLE WORKSHEET EXCEPT A1 AND B1
        .Range("A1:B1").Value = Array("Picture", "Item Number")
        .Columns("A").EntireColumn.ColumnWidth = 20
        .Rows.EntireRow.RowHeight = 60
        '---------------------------------------------------------------------
        '- CLEAR EXISTING PICTURES
        For Each s In .Shapes
            s.Delete
        Next
        '---------------------------------------------------------------------
    End With
    '====================================================
    ' *** NB. AMEND LINE BELOW FOR CORRECT FILE SUFFIX
    PictureFname = Dir(PictureSourceFolder & "*.jpg")    'ALL THE PICTURES ARE  "*.jpg"
    '===================================================
    '- loop to get each picture file from the folder
    While PictureFname <> ""
        Application.StatusBar = PictureFname
        '---------------
        ADD_NEW_PICTURE         ' CALL SUBROUTINE BELOW
        '---------------
        PictureFname = Dir
    Wend
    '------------------------------------------------------------------------
    SORT_DATA_AND_PICTURES      ' CALL SUBROUTINE BELOW
    '------------------------------------------------------------------------
    '-- close
    Application.ScreenUpdating = True
    Range("A1").Select      ' remove Selection from the picture
    MsgBox ("Done.")
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
End Sub
'======= end of main routine==================================================
 
'=============================================================================
'- SUBROUTINE TO ADD A NEW PICTURE TO A WORKSHEET
'- Column A : Add picture & size to the cell
'-            Name picture as file name(no suffix). Picture name to cell
'- Column B : File Name without suffix
'=============================================================================
Private Sub ADD_NEW_PICTURE()
    Dim ItemName As String
    ItemName = Left(PictureFname, Len(PictureFname) - 4)
    '-------------------------------------------------------------------------
    '- INSERT PICTURE
    PictureFullname = PictureSourceFolder & PictureFname
    ToSheet.Pictures.Insert(PictureFullname).Select
    '-------------------------------------------------------------------------
    '- POSITION PICTURE
    With ToSheet.Cells(ToRow, 1)
        .Value = ItemName
        Selection.Name = ItemName
        Selection.Top = .Top
        Selection.Left = .Left
        Selection.Height = .Height
        Selection.Width = .Width
    End With
    '-------------------------------------------------------------------------
    ToSheet.Cells(ToRow, 2).Value = ItemName
    ToRow = ToRow + 1
End Sub
'=============================================================================
'=============================================================================
'- SORT DATA & PICTURES
'- CALLED FROM ABOVE - BUT THIS ROUTINE CAN BE USED ON ITS OWN
'- assumes that cells and pictures are the same size already
'- ....... and the cells contain the picture names
'=============================================================================
Sub SORT_DATA_AND_PICTURES()
    Dim ws As Worksheet
    Dim rw As Long
    Dim LastRow As Long
    Dim PictureName As String
    '-------------------------------------------------------------------------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set ws = ActiveSheet
    LastRow = ws.Range("A65536").End(xlUp).Row
    '-------------------------------------------------------------------------
    '- SORT DATA
    ws.Range("A1").Sort Key1:=Range("B2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
    '-------------------------------------------------------------------------
    '- PUT PICTURES INTO CORRECT CELLS
    '- assumes that cells and pictures are the same size already
    For rw = 2 To LastRow
        With ws.Cells(rw, 1)
            PictureName = .Value
            ws.Shapes(PictureName).Select
            Selection.Top = .Top
            Selection.Left = .Left
        End With
    Next
    '-------------------------------------------------------------------------
    Application.Calculation = xlCalculationAutomatic
    Range("A1").Select      ' remove Selection from the picture
    Beep
End Sub
'=========== END OF ROUTINE ==================================================
Thanks.
 

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
You left off the last backslash from
Code:
PictureSourceFolder = _
   "C:\Users\Gary\Desktop\Website\Kondrotas Photots\New folder\"
When I tested, for some reason the sort with Header:=xlGuess did not work correctly this time, so please change to
Code:
Header:=xlYes
 

Forum statistics

Threads
1,081,850
Messages
5,361,687
Members
400,648
Latest member
mamamia93

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top