Flytte alle filer fra mappe 1 til mappe 2 med en makro?

Vil det ikke kræve en knap pr. række? Der kunne jo også være andre muligheder - evt.via en knap i en værktøjslinie eller højreklik i rækken eller...

Jo det vil kræve en knap til at aktivere hver makro. Stort arbejde, men det er det eneste jeg kan komme på med mit ringe kendskab. Kan man starte makroen ved at klikke på en celle med nummeret for destinationsmappen?
Har du et forslag?

Ja - det kan man. Prøv evt. at sende en model af arket -

PS: Skal makroen også oprette den relevante mappe, hvis den ikke findes?

Mapperne findes på forhånd, så de skal ikke oprettes.

Rem Version 2 21-09-2009
Rem --------------------
Rem Super-kontekst
Rem Const frasti = "C:\Documents and Settings\pb.KHNBPB\Skrivebord\Brenderup2\Camera"
Rem Const tilSti = "C:\Documents and Settings\pb.KHNBPB\Skrivebord\Brenderup2\"

Rem BW-kontekst
Const fraSti = "d:\data\bw.v-log\My Documents\BWVBA\Camera"
Const tilsti = "d:\data\bw.v-log\My Documents\BWVBA\Test2\"

Const førsteBilledRække = 5
Const billedKolonneNr = 25                          'Y

Rem Version 2 - 16-09-2009
Rem ----------------------
Const rød = &HC0C0FF
Dim bagGrund
Const fraKolNr = 2                                  'B
Const tilKolNr = 14                                'N
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ræk As Long, kol As Byte, billedMappeNr
    ræk = Target.Row
    kol = Target.Column
   
    If kol > fraKolNr And kol <= tilKolNr Then
            checkudfyldt ræk, kol - 1              'Target.Address
    Else
        If kol = billedKolonneNr And Target.Value = "" Then
            billedMappeNr = ræk - (førsteBilledRække - 1)
            flytJpgFiler tilsti + CStr(billedMappeNr)
            Target.Value = billedMappeNr
            Target.Font.Bold = True
        End If
    End If
End Sub
Private Sub checkudfyldt(ræk, kol)
    For Each cc In Range(Cells(ræk, fraKolNr), Cells(ræk, kol)).Cells
        If cc.Value = "" Then
            cc.Cells.Select
            MsgBox ("Celle skal udfyldes!")
            cc.Interior.ColorIndex = 3
            Exit Sub
        Else
            cc.Interior.ColorIndex = Cells(ræk, fraKolNr).Interior.ColorIndex
        End If
    Next
End Sub
Private Sub flytJpgFiler(tilMappe)
Dim fs, f, f1, fc
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(fraSti)
    Set fc = f.Files
   
    For Each f1 In fc
        If LCase(Right(f1.Name, 3)) = "jpg" Then
            FileCopy fraSti + "\" + f1.Name, tilMappe + "\" + f1.Name
Rem slet camera-filen
            Kill fraSti + "\" + f1.Name
        End If
    Next
End Sub

Igen en perfekt løsning på min opgave.
Mange tak for hjælpen.
Hilsen Bjarne :-)

Selv tak...