Autofilter VBA werkt niet goed als er geen data is

Status
Niet open voor verdere reacties.
L

lieke66

Gebruiker
Lid geworden
29 jul 2016
Berichten
47
Hi allemaal,

Ik loop vast bij mijn project, al ben ik trots op het feit hoe ver ik gekomen ben.. maar dat terzijde :)

Ik heb op een blad ("alle data") data staan van allerlei zendingen van verschillende klanten.
Deze zendingen wil ik graag op de andere tabbladen krijgen bij de desbetreffende klant.

Hiervoor heb ik gebruik gemaakt van een autofilter; Selecteer zendingen en kopieer deze naar desbetreffende. Daarna, verwijder de data op blad "alle data".
Dit gaat goed. Tot dat er geen zendingen zijn van de desbetreffende klant op het blad "alle data".

Wanneer de klant niet voorkomt in de zendingen, dan kopieert ie wel de header naar desbetreffende klant en verwijdert ie de header op blad "alle data" en daarna loopt ie vast op .ShowAllData

Ik heb al gegoogled, hier op gezocht en er is veel over geschreven.. maar helaas is het mij nog niet gelukt om het op te lossen.

Wat ik verwacht:
Als er geen data is voor de desbetreffende klant, niks doen en door gaan naar de volgende (dus ook niet de header kopieren en verwijderen).

Code: 
Sub filterKlant()
'
'
Dim wsData As Worksheet, wsKlant As Worksheet, ws As Worksheet
Dim SourceRng   As Range, DestCell  As Range
Dim LR As Integer
Dim klant As String

Set wsData = Workbooks("Facturatie.xlsm").Worksheets("Alle data")

For Each ws In Worksheets

    MsgBox (ws.Name)
    klant = ws.Name
    
   If ws.Name = "Facturatie" Or ws.Name = "Alle data" Then
   Else
       Set wsKlant = Workbooks("Facturatie.xlsm").Worksheets(klant)
    
       wsData.Range("A1:R1").AutoFilter Field:=13, Criteria1:= _
            "*" & klant & "*"
       LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
       Set SourceRng = wsData.Range("A2:R" & LR).SpecialCells(xlCellTypeVisible)
       Set DestCell = wsKlant.Range("A" & Rows.Count).End(xlUp).Offset(1)
       SourceRng.Copy DestCell
       SourceRng.Offset(0, 0).SpecialCells _
        (xlCellTypeVisible).EntireRow.Delete
        wsData.ShowAllData 'ERROR!
    End If
Next

'TODO: als geen zendingen, loop niet vast
'TODO: geef melding hoeveel regels

End Sub

Op of aanmerkingen op de rest van mijn code mag, ik ben lerende en leer graag.
 

Bijlagen

  • TestA.xlsm
    67,6 KB · Weergaven: 28
Maak er dit van:
Code: 
On Error Resume Next
wsData.ShowAllData 'Geen error meer :)
On Error Goto 0
 
Of:
Code: 
Sub filterKlant()
Dim sh As Worksheet
Application.ScreenUpdating = 0
With Sheets("alle data").Cells(1).CurrentRegion
For Each sh In Sheets
 If sh.Name <> "Facturatie" And sh.Name <> "Alle data" Then
   .AutoFilter 13, "*" & sh.Name & "*"
   .Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
   .AutoFilter
 End If
Next sh
End With
End Sub
 
Laatst bewerkt:
Beiden bedankt voor jullie input!

@Edmoor: deze had ik ook gevonden. Weet niet meer of ik idd geen error meer had, maar de macro werkte nog steeds niet naar verwachting.

@HSV: Dank! Code toch weer netter. Ik heb 1 toevoeging gedaan:
Code: 
.Offset(1).EntireRow.Delete

Doet het perfect :)
 
Ik heb het iets aangepast.
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan