Macro to find the lowest value and cut/insert to a different cell

Hello to the VBA pros here,

Is it possible for VBA macro to do this?
I wish to highlight a section of cells and have it automatically select the lowest value out of each row, cut that cell and 1 cell to it's right and have it be inserted to the Z column.

It's basically a bunch of prices and vendor names listed to the right of the price and i want to take the lowest price and have it be cut and inserted (has to be the insert function instead of paste) to the Z column, just by highlighting the cells i want the macro to affect.

Example of my worksheet. I high-lite this entire thing and hit the macro.

|12.00|vendor A|22.00|vendor B|15.00|vendor C
| 5.00|vendor A| 7.00|vendor B| 8.00|vendor C
|45.00|Vendor A|45.00|Vendor B|40.00|Vendor C <------ (I have no idea how the macro will affect prices that are the same, maybe have it ignore same prices and i will pick manually)

Seems like quite a complicated macro. Appreciate it if any experts here can figure it out.

Cause ultimately i want to actually move all the lowest value to one column for easy reference and to do calculations with formulas.

Originally Posted by Kaper

please use attachment on the forum.

SMALL sample Excel workbook(s) (10-20 rows of data is usually enough) Please don't attach a picture of one (no-one will want to re-type all your stuff before starting).

1. Make sure that your sample data are truly REPRESENTATIVE of your real data. (If trere are typical cases like: all unique values/duplicates could occur, day/night, nobody present/several persons at once, before/on/past due, etc. - please show them all or at least indicate in text) The use of unrepresentative data is very frustrating and can lead to long delays in reaching a solution.

2. Make sure that your desired solution(s) is/are also shown (mock up the results manually). (also try showing the final (ultimate) step)

3. Make sure that all confidential/restricted information (either personal or business) like real e-mails, social security numbers, bank accounts, etc. is removed first!!

To attach an Excel file you have to do the following: Just before posting, scroll down and press Go Advanced button and then scroll down and press Manage Attachments link. Now follow the instructions at the top of that pop-up screen.

I have edited my post to explain exactly what i want to achieve and attached a sample file.

This seems to work.

May require some fine tuning and error handling as per your requirements.

Sub FindMin()
    firstrow = Selection.Row
    FIRSTCOL = Selection.Column
    rowscount = Selection.Rows.Count
    colscount = Selection.Columns.Count
    
    For R = firstrow To firstrow + rowscount - 1
        minval = 999999999999#
        MINVALCOL = 0
        For c = FIRSTCOL To FIRSTCOL + colscount - 1 Step 2
            cellval = Val(Cells(R, c).Text)
            If (cellval <> 0) And (cellval < minval) Then
                minval = cellval
                MINVALCOL = c
            End If
        Next
        
        If MINVALCOL > FIRSTCOL Then
            Range(Cells(R, MINVALCOL), Cells(R, MINVALCOL + 1)).Select
            Selection.Cut
            Cells(R, FIRSTCOL).Select
            Selection.Insert Shift:=xlToRight
        End If
    Next
    
    MsgBox "Done"
    
End Sub

Originally Posted by Kaper

This shall work too (I started it earlier, but had to leave the office). If there are 2 or more minimal values all will be moved to column I, K, etc.
Mote that moving cells can make your formula referring to column I invalid. To make it independant on moving cells you could either use MIN (you anyway look for lovest value) or INDIRECT function inside your CEILING

Sub test()
Dim arr, i As Long, j As Long, k As Long, startr As Long, startc As Long
Dim minval As Double, helper1, helper2
Application.ScreenUpdating = False
arr = Selection.Value
startr = Selection.Cells(1, 1).Row - 1
startc = Selection.Cells(1, 1).Column - 1
For i = 1 To UBound(arr)
  If IsNumeric(arr(i, 1)) And Len(arr(i, 1)) > 0 Then
    minval = arr(i, 1)
  Else
    minval = Application.Max(Selection)
  End If
  For j = 3 To UBound(arr, 2) - 1 Step 2
    If IsNumeric(arr(i, j)) And Len(arr(i, j)) > 0 Then
      If arr(i, j) <= minval Then
        Cells(startr + i, startc + j).Resize(1, 2).Cut
        Cells(startr + i, startc + 1).Resize(1, 2).Insert shift:=xlToRight
        minval = arr(i, j)
        Application.CutCopyMode = False
      End If
    End If
Next j, i
Application.ScreenUpdating = True
End Sub

Works amazing!! Would love to give you more rep but can't for now