21. maj 2006 - 20:28Der er
3 kommentarer og 2 løsninger
Flyt data fra et ark til et andet inkl formateringen.
Jeg har et ark med en opgave liste, hvor jeg ændre status alt efter hvor lang i processen opgaven er. Mit problem er at når jeg ændre status fra Slut til Arkiv, så vil jeg flytte hele linien (inkl farve status for formatering)til et andet ark på næste frie linie. Jeg har en overskrift og lign på de første 4 linier.
Sub FlytTilArkiv() Dim DataEnd As Long, C As Range, DataArk As Object, I As Long, KopiArk As Object Set DataArk = Worksheets("Ark1") ' Ret til dit dataark Set KopiArk = Worksheets("Ark2") ' Ret til dit Arkivark DataEnd = DataArk.Range("A65536").End(xlUp).Row For I = DataEnd To 4 Step -1 If DataArk.Cells(I, "A") = "Arkiv" Then ' ret A til den kolonne der skal tjekkes på og "Arkiv", til det den skal finde DataArk.Rows(I).Copy KopiArk.Range("A65536").End(xlUp).Offset(1, 0) ' kopierer ræken over DataArk.Rows(I).Delete 'Sletter rækken fra DataArk End If Next Set DataArk = Nothing Set KopiArk = Nothing End Sub
Det virker i princippet, men jeg får en fejl. Jeg har forsøgt at debugge min samlede kode. Se nedestående og som jeg kan se, så når den har udfør DELETE linien i din kode så starter den forfra og fejler så i linien "Select Case UCase(.Value)" da target ikke har nogen værdi. Kan du hjælpe med at løse dette. Jeg tror det sker ved at arket bliver arktivt igen og starter makronen igen. eller hvad.?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Counter As Integer Dim r As Range 'Dim C As Range Dim tmp() As Variant Dim DataEnd As Long, DataArk As Object, I As Long, KopiArk As Object
Set DataArk = Worksheets("Ny opgave") ' Ret til dit dataark Set KopiArk = Worksheets("Afsluttet") ' Ret til dit Arkivark
If ActiveCell.Column = 3 Then With Worksheets("Ny Opgave") With Target Select Case UCase(.Value) Case "NY" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 6 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "I GANG" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 43 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "OBSERVATION" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 8 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "SLUT" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 46 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "ARKIV" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 46 Next Counter DataEnd = DataArk.Range("A65536").End(xlUp).Row For I = DataEnd To 4 Step -1 If DataArk.Cells(I, "C") = "Arkiv" Then ' ret A til den kolonne der skal tjekkes på og "Arkiv", til det den skal finde DataArk.Rows(I).Copy KopiArk.Range("A65536").End(xlUp).Offset(1, 0) ' kopierer ræken over DataArk.Rows(I).Delete 'Sletter rækken fra DataArk End If Next I
Case Else For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = xlNone Next Counter End Select Set DataArk = Nothing Set KopiArk = Nothing End With End With End If
Det virker i princippet, men jeg får en fejl. Jeg har forsøgt at debugge min samlede kode. Se nedestående og som jeg kan se, så når den har udfør DELETE linien i din kode så starter den forfra og fejler så i linien "Select Case UCase(.Value)" da target ikke har nogen værdi. Kan du hjælpe med at løse dette. Jeg tror det sker ved at arket bliver arktivt igen og starter makronen igen. eller hvad.?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Counter As Integer Dim r As Range 'Dim C As Range Dim tmp() As Variant Dim DataEnd As Long, DataArk As Object, I As Long, KopiArk As Object
Set DataArk = Worksheets("Ny opgave") ' Ret til dit dataark Set KopiArk = Worksheets("Afsluttet") ' Ret til dit Arkivark
If ActiveCell.Column = 3 Then With Worksheets("Ny Opgave") With Target Select Case UCase(.Value) Case "NY" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 6 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "I GANG" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 43 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "OBSERVATION" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 8 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "SLUT" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 46 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "ARKIV" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 46 Next Counter DataEnd = DataArk.Range("A65536").End(xlUp).Row For I = DataEnd To 4 Step -1 If DataArk.Cells(I, "C") = "Arkiv" Then ' ret A til den kolonne der skal tjekkes på og "Arkiv", til det den skal finde DataArk.Rows(I).Copy KopiArk.Range("A65536").End(xlUp).Offset(1, 0) ' kopierer ræken over DataArk.Rows(I).Delete 'Sletter rækken fra DataArk End If Next I
Case Else For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = xlNone Next Counter End Select Set DataArk = Nothing Set KopiArk = Nothing End With End With End If
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Counter As Integer Dim r As Range 'Dim C As Range Dim tmp() As Variant Dim DataEnd As Long, DataArk As Object, I As Long, KopiArk As Object
Set DataArk = Worksheets("Ny opgave") ' Ret til dit dataark Set KopiArk = Worksheets("Afsluttet") ' Ret til dit Arkivark
If Target.Column = 3 Then With Worksheets("Ny Opgave") With Target Select Case UCase(.Value) Case "NY" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 6 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "I GANG" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 43 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "OBSERVATION" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 8 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "SLUT" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 46 Next Counter Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=7, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1 _ :=xlSortNormal
Case "ARKIV" For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = 46 Next Counter
If Target = "Arkiv" Then ' ret A til den kolonne der skal tjekkes på og "Arkiv", til det den skal finde DataArk.Rows(Target.Row).Copy KopiArk.Range("A65536").End(xlUp).Offset(1, 0) ' kopierer ræken over Application.EnableEvents = False DataArk.Rows(Target.Row).Delete 'Sletter rækken fra DataArk
End If
Case Else For Counter = 1 To 9 ActiveCell.EntireRow.Cells(1, Counter).Interior.ColorIndex = xlNone Next Counter End Select Set DataArk = Nothing Set KopiArk = Nothing End With End With End If Application.EnableEvents = True End Sub
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
Ny bruger
Nybegynder
Opret
Preview
