VBA: Onder voorwaarden regels naar blad kopieren en sorteren.

[burley]

Ik ben bezig (zou graag willen) een excel macro te maken waardoor ik vanuit mijn factuurbestand (excel) met de spreekwoordelijke "druk op de knop" facturen (regels) die langer dan een bepaald aantal dagen openstaan naar een specifiek blad kan kopiëren en daar op klantnaam laat sorteren. Voor de duidelijkheid, de oude regel moet wel blijven staan. Het eerste gedeelte lukt heel aardig met onderstaande code.

Ik heb dit nodig voor mijn administratie (ben zelfstandig) zodat ik hiermee mijn tekst/data integratie met word kan vergemakkelijken en de klanten met te lang openstaande facturen een herinnering kan toezenden.
Onderstaande code is slechts een deel, deze kopieert alleen de regels welke een 1e herinnering moeten ontvangen. Het vervolg is dat deze macro naast de 1e herinneringen, hetzelfde doet voor de 2e herinnering en de laatste aanmaning.

Helaas zijn er een paar problemen waar ik niet uit kom (ben helaas geen held in vba):

- Allereerst dient, voorafgaand aan het kopiëren naar het specifieke blad, dit blad te worden leeggemaakt. Zodat alle oude regels daarvan worden verwijderd.
- Na het kopiëren, dienen de regels te worden gesorteerd en wel op klantnaam.
- In een ideale wereld kan ik de criteria wanneer een regel gekopieerd wordt zelf bepalen dmv een/meerdere celwaarde(n).

Zoals in onderstaand code al gebeurd is het voor mij niet noodzakelijk dat de specifieke bladen actief worden.

Ik ben heel benieuwd naar jullie feedback! En natuurlijk alvast mijn dank voor eventuele input!

Sub FilterToSheets()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim SheetNames As Variant
Dim i As Long
Dim LR As Long
Application.ScreenUpdating = False
'EDIT
Set SourceSheet = Sheets("Betalingen")
SheetNames = Array("OPENSTAAND")
Const FilterColumn = 25
Const FilterColumn_1 = 27
'END EDIT

    With SourceSheet
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    
        For i = 0 To UBound(SheetNames)
        Set TargetSheet = Worksheets(SheetNames(i))
        TargetSheet.Cells.ClearContents
        
            With .Range("A3:BD" & LR)
            .AutoFilter Field:=FilterColumn, Criteria1:=SheetNames(i)
            .AutoFilter Field:=FilterColumn_1, Criteria1:=">=35", Criteria2:="<=50"
            .Offset(0, 0).Copy TargetSheet.Range("A2")
            End With
        Next i

    End With

ActiveSheet.ShowAllData

Application.ScreenUpdating = True

End Sub

Hier het voorbeeld bestand Bekijk bijlage betalingsoverzicht_temp.xlsm "CTRL + M" activeert de macro

 

[Niels28]

Met een voorbeeldbestand zal je sneller een reactie krijgen .


Niels

 

[burley]

Je hebt helemaal gelijk!

Bijgaand een voorbeeld bestand, CTRL + M activeert de macro. Het resultaat zie je dan vervolgens op de pagina "OPENSTAAND".

Bekijk bijlage betalingsoverzicht_temp.xlsm

 

[burley]

Niemand met enige input?

 

[Cobbe]

Deze macro loopt aardig in de richting, heb helaas nu geen tijd om hem echt af te werken.
Ook heb ik een opgenomen sorteermacro toegevoegd.

Sub RijCutPasteNewSheet()
' Onderdruk eventuele meldingen
Application.DisplayAlerts = False
' Actieve werkblad
With Sheets("Betalingen")
 'Oude gegevens wissen
 Sheets("Openstaand").Range("A2:IV500").ClearContents
' bereik A1 tot en met kolom BK + aantal gebruikte rijen
' zet daar een autofilter op en filter op "Klaar" in de 25de kolom
    .Range("A1:BK" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter 25, "OPENSTAAND"
' hier wordt in het bereik de zichtbare cellen benoemd na het filteren
    Set Rng = Intersect(.AutoFilter.Range.EntireRow, .Columns(1))
    Set rng1 = Rng.Offset(1).Resize(Rng.Rows.Count - 1, 27).SpecialCells(xlVisible)
' hier begint de wegschrijving naar benoemd blad
  With Sheets("Openstaand")
' de eerste vrije regel berekenen
    LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
' copiëer bereik rng en verplaats naar blad 'Gedane taken' in kolom A rij LR
    rng1.Copy .Range("A" & LR).Resize(, 27)
Sorteren  'het sorteren gebeurt in een aparte opgenomen macro
' verwijder de zichtbare cellen (range(rng)
   ' rng1.Delete
  End With
 ' verwijder de filter
    .ShowAllData
End With
Application.DisplayAlerts = True
End Sub

sorteren:

Sub Sorteren()
'
' Sorteren Macro
'

'
    Range("A2:Q100").Select
    ActiveWorkbook.Worksheets("Openstaand").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Openstaand").Sort.SortFields.Add Key:=Range( _
        "F2:F100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Openstaand").Sort
        .SetRange Range("A1:Q100")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
End Sub

 

[snb]

Dit lijkt me ruim voldoende:

Sub M_snb()
   Sheets("Openstaand").UsedRange.Clearcontents

   With Sheets("betalingen")
        .Cells(1, 100).Resize(2) = Application.Transpose(Array("Datum", "<=" & 1 * (Date - 28)))
        .Cells(1).CurrentRegion.AdvancedFilter 2, .Cells(1, 100).CurrentRegion, Sheets("openstaand").Cells(1)
    End With
    
    With Sheets("Openstaand")
        .Cells(1).CurrentRegion.Sort .Cells(1, 6)
    End With
End Sub

 

[Cobbe]

Vwoila !! Dat is nu de hand van de meester!!

 

[burley]

Beste Cobbe en SNB, bedankt voor jullie input!!

De macro van SNB voldoet bijna, probleem is dat hij niet alle cellen uit de rij kopieert en dat ik de onder en bovengrens niet duidelijk aangeven.
Of althans ik begrijp niet hoe ik dat moet doen hiermee.

Zouden jullie een en ander van wat uitleg kunnen voorzien? Wat ik begrijp heb ik bijgevoegd, maar het voornaamste probleem is dat ik niet begrijp waarom niet de hele rij wordt gekopieerd. En ik kan ook geen boven en ondergrens aangeven als voorwaarde voor het kopieren.

Sub M_snb()
   Sheets("Openstaand").UsedRange.ClearContents
    '==>> hier wordt het doelblad leeggemaakt
    
   With Sheets("betalingen")
        .Cells(1, 100).Resize(2) = Application.Transpose(Array("Datum", "<=" & 1 * (Date - 28)))
        '==>> Hier wordt het bereik bepaald waarmee wordt bepaald welke rijen moeten worden gekopieerd.
        .Cells(1).CurrentRegion.AdvancedFilter 2, .Cells(1, 100).CurrentRegion, Sheets("openstaand").Cells(1)
    End With
    
    With Sheets("Openstaand")
        .Cells(1).CurrentRegion.Sort .Cells(1, 6)
        '==>> Hier wordt de cel waarop moet worden gesorteerd geselecteerd
    End With
End Sub

 

[Cobbe]

Heb de uitleg in mijn code gezet, hoop dat dit u een beetje wijzer maakt:

Sub RijCutPasteNewSheet()
' Onderdruk eventuele meldingen
Application.DisplayAlerts = False
' Actieve werkblad
With Sheets("Betalingen")
 'Oude gegevens wissen
 Sheets("Openstaand").UsedRange.ClearContents
  .Range("A1:BK1").Copy Sheets("Openstaand").Cells(1, 1)
' bereik A1 tot en met kolom BK + aantal gebruikte rijen
' zet daar een autofilter op en filter op "Klaar" in de 25de kolom
    .Range("A1:BK" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter 25, "OPENSTAAND"
' hier wordt in het bereik de zichtbare cellen benoemd na het filteren
    Set Rng = Intersect(.AutoFilter.Range.EntireRow, .Columns(1))
    Set rng1 = Rng.Offset(1).Resize(Rng.Rows.Count - 1, 63).SpecialCells(xlVisible)
' hier begint de wegschrijving naar benoemd blad
  With Sheets("Openstaand")
' de eerste vrije regel berekenen
    LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
' copiëer bereik rng en verplaats naar blad 'Gedane taken' in kolom A rij LR
    rng1.Copy .Range("A" & LR).Resize(, 63)
'het sorteren
    With Sheets("Openstaand")
        .Cells(1).CurrentRegion.Sort .Cells(1, 6)
    End With

' verwijder de zichtbare cellen (range(rng)
   ' rng1.Delete
  End With
 ' verwijder de filter
    .ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[snb]

Zet in cell(1,101) eens een *

 

[burley]

Beste Cobbe & SNB, opnieuw bedankt voor de supersnelle reacties.

@Cobbe, bedankt! Werkt bijna perfect!
Alleen worden ook in deze macro alle rijen met status "Openstaand" gekopieerd en wordt er niet gekeken naar de termijn (bijvoorbeeld tussen 35 en 70 dagen). Dat heb ik nu deels getackeld door het toevoegen van een extra sorteersleutel, maar dan kijkt hij of naar de max of min termijn. Niet naar allebei Hoe kan ik dat doen?
> Is er ook een manier om de sorteersleutel (naast openstaand) afhankelijk te laten zijn van waarden welke ik in een cel op het blad "Betalingen" in kan vullen?
> Hoe kan ik zorgen dat de titels mee worden gekopieerd (of blijven staan) en niet mee worden genomen in het sorteerproces?

@SNB: Het zal aan mij liggen, maar ik begrijp echt niet wat je bedoelt met Zet in cell(1,101) eens een * /hoe de macro werkt. Bovendien kopieert hij alle rijen welke aan de datumvoorwaarde voldoen, ongeacht de status van de factuur (betaald/onbetaald).
Dit in tegenstelling tot mijn eerdere geposte macro of die van Cobbe. Bovendien worden de gekopieerde rijen gekopieerd t/m kolom U, terwijl er ook in de resterende kolommen (t/m bk) nog data staat. Data die wel mee moet worden gekopieerd. Wil zeker niet ondankbaar lijken, maar ik begrijp niet hoe ik deze aan kan passen of hoe hij werkt.

Sub RijCutPasteNewSheet()
Application.DisplayAlerts = False
With Sheets("Betalingen")

 Sheets("Openstaand").UsedRange.ClearContents
  .Range("A1:BK1").Copy Sheets("Openstaand").Cells(2, 1)
    .Range("A2:BK" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter 25, "OPENSTAAND"
    .Range("A2:BK" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter 27, "<=70"

    

    Set Rng = Intersect(.AutoFilter.Range.EntireRow, .Columns(1))
    Set rng1 = Rng.Offset(1).Resize(Rng.Rows.Count - 1, 63).SpecialCells(xlVisible)

  With Sheets("Openstaand")

    LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    rng1.Copy .Range("A" & LR).Resize(, 63)
    With Sheets("Openstaand")
        .Cells(2).CurrentRegion.Sort .Cells(2, 6)
    End With
  End With
    .ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[burley]

Zijn er nog toevoegingen?

 

[burley]

Echt helemaal niemand die mij hier verder mee kan helpen?

 

[Cobbe]

Test deze eens; nu tussen 30 en 70 dagen en openstaand:

Sub RijCutPasteNewSheet()
' Onderdruk eventuele meldingen
Application.DisplayAlerts = False
' Actieve werkblad
With Sheets("Betalingen")
 'Oude gegevens wissen
 Sheets("Openstaand").Range("A2:IV500").ClearContents
' bereik A1 tot en met kolom BK + aantal gebruikte rijen
' zet daar een autofilter op en filter op "Klaar" in de 25de kolom
    With .Range("A1:BK" & .Range("A" & .Rows.Count).End(xlUp).Row)
      .AutoFilter 25, "OPENSTAAND"
      .AutoFilter Field:=31, Criteria1:=">=30", Operator:=xlAnd, Criteria2:="<=70"
    End With
' hier wordt in het bereik de zichtbare cellen benoemd na het filteren
    Set Rng = Intersect(.AutoFilter.Range.EntireRow, .Columns(1))
    Set rng1 = Rng.Offset(1).Resize(Rng.Rows.Count - 1, 50).SpecialCells(xlVisible)
' hier begint de wegschrijving naar benoemd blad
  With Sheets("Openstaand")
' de eerste vrije regel berekenen
    LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
' copiëer bereik rng en verplaats naar blad 'Gedane taken' in kolom A rij LR
    rng1.Copy .Range("A" & LR).Resize(, 27)
Sorteren  'het sorteren gebeurt in een aparte opgenomen macro
' verwijder de zichtbare cellen (range(rng)
   ' rng1.Delete
  End With
 ' verwijder de filter
    .ShowAllData
End With
Application.DisplayAlerts = True
End Sub

 

[snb]

Als je nou eens wat meer moeite deed om de aangereikte suggesties te begrijpen was je al een stuk verder geweest.
Begin dus eerst met je zelf te 'helpen'.