"Archiveren" Een hele rij knippen van het ene werkblad naar het andere !!!

[McMacro]

Beste mede-exellers,

Ik hoop dat jullie er iets mee kunnen. Helaas heb ik een vrij omslachtige code om een rij uit een beveiligd werkblad te knippen en in een ander werkblad te plakken.

Wat ik dus doe in deze code: Ik laat de macro in Kolom AN vanaf rij 4 en verder naar beneden zoeken naar het woord "Afgehandeld", vervolgens wordt de hele rij geselecteerd en naar het blad archief gekopieerd. Daarna gaat hij terug naar het 'Sheet 1' om de nieuwe rij met "Afgehandeld" te zoeken en het hele proces opnieuw te laten verlopen.

Helaas gebeurd dit maar 2 keer. Ook al heb ik 5 rijen op "afgehandeld" staan, dan nog kopieerd de macro er maar maximaal 2 !?

Wat gaat er fout? ( de code mag eenvoudiger ;-) )

Public Sub Archiveren()

'Run "ShowTheCellsA"
'Run "ShowTheCellsH"

Application.ScreenUpdating = False
Sheets("Sheet1").Unprotect password:="xxxx1"
Sheets("Archief").Unprotect password:="xxxx2"

With Worksheets("Sheet1").Range("AN4:AN500")
If ActiveSheet.FilterMode Then
    ActiveSheet.ShowAllData
    ActiveSheet.Outline.ShowLevels columnlevels:=2
End If

Do
Set A = .Find("Afgehandeld", LookIn:=xlValues, SearchDirection:=xlNext)
If Not A Is Nothing Then
    B = A.Row
    Rows(B).Copy
    Worksheets("Archief").Select
    Sheets("Archief").Unprotect password:="xxxx2"
    ActiveSheet.Outline.ShowLevels columnlevels:=2
    
    With Worksheets("Archief").Range("AN4:AN1000")
        Set z = .Find("", LookIn:=xlValues)
        If Not z Is Nothing Then
        z = z.Row
            
    With Worksheets("Archief").Range("A" & CStr(z))
        .PasteSpecial xlPasteValues
        .PasteSpecial SkipBlanks:=False
        .PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
'On Error GoTo 0
    
End With
End If

End With
    Worksheets("Sheet1").Select
    Sheets("Sheet1").Unprotect password:="xxxx2"
    ActiveSheet.Outline.ShowLevels columnlevels:=1
    Rows(B).Select
    Selection.Delete
End If

Loop Until A Is Nothing

End With
    With Worksheets("Sheet1").Select
    Sheets("Sheet1").Unprotect password:="xxxx1"
    ActiveSheet.Outline.ShowLevels columnlevels:=1

End With
    With Worksheets("Archief")
    Sheets("Archief").Unprotect password:="xxxx2"
    .Select
    .Outline.ShowLevels columnlevels:=1
    .Range("A4:AN500").Locked = True
    
    Application.ScreenUpdating = True

End With

'    Run "HideTheCellsA"
'    Run "HideTheCellsH"

End Sub

Ik hoop dat jullie er iets mee kunnen.

Met vriendelijke groet,

McMacro

 

[danny147]

Beste McMacro

Deze verplaatst de rijen naar tabblad archief en verwijderd de rijen.
Plaats deze code in een module, ga naar Sheet1 en activeer de code via ALT + F8

Sub Afgehandeld()
    Application.ScreenUpdating = False
   Dim c As Range
   Dim rw As Long
   
   For Each c In [AN4:AN1000]
        If c = "Afgehandeld" Then
            c.Rows.EntireRow.Copy
            
           ['Archief'!A65536].End(xlUp).Offset(1, 0).Insert Shift:=xlDown

            
        End If
    Next
   For rw = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
     If Cells(rw, "AN") = "Afgehandeld" Then Rows(rw).Delete
    Next
    With Application
    
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

Groetjes Danny :thumb:

 

[McMacro]

Beste Danny,

Hartelijk bedankt voor de snelle reactie.

Sheet1 is reeds in gebruik. De lijst is gevuld met informatie die niet meer verloren mag gaan.

Ik heb in Sheet1 2x een groepje kolommen "Gegroepeerd" om niet al te belangrijke gegevens te verbergen bij het maken van een afdruk van het werkblad, zodat het nog leesbaar is op A3 formaat liggend. Maar omdat het werkblad volledig vergrendeld en beveiligd is, liep ik bij de vorige code zoals u hierboven ziet tegen veiligheidsprocedures aan. Tevens moet ervoor gezorgd worden dat de autofilter uitstaat en de verborgen kolommen moeten eerst weer zichtbaar gemaakt worden alvorens ze gekopieerd kunnen worden naar het blad "Archief" zodat ook daar nog aale informatie voorhanden is.

Mijn vraag: Kan dat met de code die u gemaakt heeft?

Met vriendelijke groet,

McMacro

 

[McMacro]

Helaas lukt het niet helemaal om alle rijen te knippen uit 'Sheet1' en te plakken in 'Sheet2'.

Als test heb ik rij 4 t/m 7 op "Afgehandeld" gezet en de rijen in kolom A A, B, C, D genoemd vervolgens de volgende macro laten lopen:

Sub Afgehandeld()
    Application.ScreenUpdating = False
    
   Dim c As Range
   Dim rw As Long
   
   For Each c In [AN4:AN1000]
        If c = "Afgehandeld" Then
            c.Rows.EntireRow.Copy
            
            Sheets("Archief").Unprotect password:="Password"
           ['Archief'!A5000].End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown
            
        End If
    Next
    Sheets("Sheet1").Unprotect password:="Password"
   For rw = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
     If Cells(rw, "AN") = "Afgehandeld" Then Rows(rw).Delete
    Next
    With Application
    
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

Het gevolg is dat de eerste rij niet meegekopieerd wordt in het blad "Archief", dus alleen de rijen C, B, D worden weergegeven. Onder de laatste regel zet hij een extra regel neer met de voorwaardelijke opmaak van de vorige rijen !

Hoe kan dit anders? In principe moet alleen de rijen die op Afgehandeld staan in het blad "Sheet1" gekopieerd worden naar het blad "Archief" en vervolgens verwijderd worden in "Sheet1" (een verplaatsing dus).

Alvast heel erg bedankt voor de moeite.

Met vriendelijke groet,

McMacro

 

[Jack Nouws]

Hallo McMacro,

Kijk eens of je met deze macro je doelkunt bereiken.

Application.ScreenUpdating = False
  With Sheets("Blad1").UsedRange
    .AutoFilter 40, "Afgehandeld"
    .Offset(1).SpecialCells(12).Copy
     Sheets("Archief").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues
    .Offset(1).SpecialCells(12).EntireRow.Delete
    .AutoFilter
  End With
Application.ScreenUpdating = True

Met vr gr
Jack

 

[McMacro]

Beste Jack (en andere lezers),

Deze regel zorgt voor problemen: Sheets("Archief").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues

Tevens zouden de rijen ingevoegd moeten worden inplaats van geplakt.

Application.ScreenUpdating = False
  With Sheets("Blad1").UsedRange
    .AutoFilter 40, "Afgehandeld"
    .Offset(1).SpecialCells(12).Copy
     [COLOR="red"]Sheets("Archief").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues[/COLOR]
    .Offset(1).SpecialCells(12).EntireRow.Delete
    .AutoFilter
  End With
Application.ScreenUpdating = True

Aanvullende informatie:
Ik werk met Excel2000.
Het hele project is beveiligd.

Meer info nodig?

Met vriendelijke groet,

McMacro

 

[Jack Nouws]

Hallo,

probeer het eens met een lus.

Sub tst()
Application.ScreenUpdating = False
  For c = Sheets("Blad1").Cells(Rows.Count, 40).End(xlUp).Row To 2 Step -1
      If Cells(c, 40).Value = "Afgehandeld" Then
        With Rows(c)
          .Copy
           Sheets("Archief").Range("A5").Insert
          .Delete
        End With
      End If
    Next
Application.ScreenUpdating = True
End Sub

Met vr gr
Jack

 

[McMacro]

Eindelijk!!!

De oplossing !!! (voor mijn probleem dan)

Even een korte herhaling van het probleem:
Als een rij een status "Afgehandeld" krijgt in Kolom AN (of dat er nu 1 of 20 afgehandelde rijen zijn, mag niets uitmaken) dan moet er met een knop gearchieveerd kunnen worden, zodat de rijen uit blad1 naar blad2 verplaatst worden.

De voorgaande codes werkten maar gedeeltelijk. Als er meer dan 2 afgehandelde rijen waren, kopieerde de macro maar max. 2 rijen naar blad2. Dus als er in Blad1 bijvoorbeeld 20 afgehandelde zaken staan worden er maar 2 gekopieerd en de rest wordt in het niets verwijderd.

Maar hieronder de oplossing !!! (duurt wat langer, maar het werkt)

Option Explicit
Sub Archief()
    
    Dim i As Long
    Dim j As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    With Sheets("Sheet1")
    Sheets("Archief").Unprotect password:="xxxx"
    
    For i = 4 To 1000
        j = Sheets("Archief").Cells(Rows.Count, "AN").End(xlUp).Row
    
      If Range("AN" & i) = "Sheet1" Then
         Range("AN" & i).EntireRow.Copy Sheets("Archief").Range("A" & j).Offset(1, 0)
      End If
     Next i
    
    For i = 1000 To 4 Step -1
    
      If Range("AN" & i) = "Afgehandeld" Then
         Sheets("Sheet1").Unprotect password:="xxxx"
         Rows.Range("AN" & i).EntireRow.Delete Shift:=xlUp
      End If
     Next i
    End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Bedankt aan allen die hieraan meegedacht en geholpen hebben !!!

Groeten,

McMacro