Rækker fordelt på forskellige ark efter status

Sub FlyttRow()
  vArk = Cells(ActiveCell.Row, 3).Value
  vId = Cells(ActiveCell.Row, 2).Value
  vData = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, Columns.Count))
 
  For Each wsh In ThisWorkbook.Sheets
    If Not wsh.Name = "Main" Then
      MsgBox wsh.Name
      lrad = wsh.Cells(Rows.Count, 1).End(xlUp).Row
      For Each c In wsh.Cells(2, 2).Resize(lrad, 1)
        If c.Value = vId Then
          c.EntireRow.Delete
        End If
      Next
    End If
  Next
  lrad = Sheets(vArk).Cells(Rows.Count, 1).End(xlUp).Row + 1
  Worksheets(vArk).Cells(lrad, 1).Resize(1, UBound(vData, 2)) = vData
End Sub

denne stiller 2 krav:
Du må markere en celle i den rad i main som skal endres
Dine arkfaner må ha samme navn som den staus som gis i kolonne C

Rettelse:

Sub FlyttRow()
  vArk = Cells(ActiveCell.Row, 3).Value
  vId = Cells(ActiveCell.Row, 2).Value
  vData = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, Columns.Count))
  For Each wsh In ThisWorkbook.Sheets
    If Not wsh.Name = "Main" Then     
      lrad = wsh.Cells(Rows.Count, 1).End(xlUp).Row
      For Each c In wsh.Cells(2, 2).Resize(lrad, 1)
        If c.Value = vId Then
          c.EntireRow.Delete
        End If
      Next
    End If
  Next
  lrad = Sheets(vArk).Cells(Rows.Count, 1).End(xlUp).Row + 1
  Worksheets(vArk).Cells(lrad, 1).Resize(1, UBound(vData, 2)) = vData
End Sub

oyejo -> der skal mere til - for når der ændres status i kolonne C, så skal "recorden" slettes i et ark og tilføjes i et andet ark.

->flemmingdahl,
ja for at denne skal fungere,
må man Activt kjøre makroen på nytt hver gang man har endret status i kolonne C.
Hvis ønskelig, kan den lett endres til å trigge en makro
når det skjer en endring i celler i kolonne C.

men også nå sletter den den gamle record. jfr.
c.EntireRow.Delete

gjrø den ikke det da?
Ble faktisk litt usikker selv :-)

Dim Flagg As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
vArk = Cells(ActiveCell.Row, 3).Value
  vId = Cells(ActiveCell.Row, 2).Value
  vData = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, Columns.Count))
  For Each wsh In ThisWorkbook.Sheets
    If Not wsh.Name = "Main" Then
      lrad = wsh.Cells(Rows.Count, 1).End(xlUp).Row
      For Each c In wsh.Cells(2, 2).Resize(lrad, 1)
        If c.Value = vId Then
          c.EntireRow.Delete
        End If
      Next
    End If
  Next
  lrad = Sheets(vArk).Cells(Rows.Count, 1).End(xlUp).Row + 1
  Worksheets(vArk).Cells(lrad, 1).Resize(1, UBound(vData, 2)) = vData
  Flagg = False
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 And (Target.Value = "A" Or Target.Value = "B" Or _
                                            Target.Value = "C") Then
  Flagg = True
End If
End Sub

Her må A B og C endres til de verdier som kan stå i kolonne C..

If Target.Column = 3 And (Target.Value = "A" Or Target.Value = "B" Or _
                                            Target.Value = "C") Then

Denne koden må stå i kodemodulen til selve sheet "main"

Rettelse, denne vil gjøre oppgaven når status endres
Når man legger inn en ny rad i manin må makro startes manuelt

Dim Flagg As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Flagg = True Then
vArk = Cells(ActiveCell.Row, 3).Value
  vId = Cells(ActiveCell.Row, 2).Value
  vData = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, Columns.Count))
  For Each wsh In ThisWorkbook.Sheets
    If Not wsh.Name = "Main" Then
      lrad = wsh.Cells(Rows.Count, 1).End(xlUp).Row
      For Each c In wsh.Cells(2, 2).Resize(lrad, 1)
        If c.Value = vId Then
          c.EntireRow.Delete
        End If
      Next
    End If
  Next
  lrad = Sheets(vArk).Cells(Rows.Count, 1).End(xlUp).Row + 1
  Worksheets(vArk).Cells(lrad, 1).Resize(1, UBound(vData, 2)) = vData
  Flagg = False
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 And (Target.Value = "A" Or Target.Value = "B" Or Target.Value = "C") Then
  Flagg = True
End If
End Sub

Jeg har løst det på en anden måde... Download eksempel her http://www.smartoffice.dk/Tips/Eksperten/Index.asp

4 ark med navnene 'Database', 'Pending', 'Ongoing' og 'Closed'
På alle ark undtagen 'Database' har jeg placeret følgende kode

Private Sub Worksheet_Activate()
    Const iColStatus As Integer = 2
    Dim wksDB As Worksheet
    Dim rCell As Range
    Dim lRow As Long
   
    'Variable
    Set wksDB = Worksheets("Database")
    ' This row does nothing but workaround an Excel bug to ensure correct use of UsedRange
    lRow = wksDB.UsedRange.Rows.Count
   
    'Clean activesheet
    Me.UsedRange.Offset(1, 0).Clear
   
    ' Find and copy data
    For Each rCell In wksDB.UsedRange.Columns(iColStatus).Cells
        If UCase(rCell.Value) = UCase(Me.Name) Then
            rCell.EntireRow.Copy
            Me.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next rCell
       
    ' CleanUp
    Set rCell = Nothing
    Set wksDB = Nothing
End Sub

Super makro flemmingdahl :-)
takker