Data ophalen

[Djoties]

Beste Mensen,

Ik heb een macro geschreven. Maar helaas zit hierin een fout die ik niet uit krijg.
Macro haalt data uit ander bestand door eerst te filteren.
Waarde waaop gefilterd moet worden staat in a1.

Het gaat fout wanneer een waarde ingevuld is wat niet voorkomt in het bestand.
In dit geval kopiert de macro de "header" en plakt deze in het bestand. En dat wil ik dus niet hebben.

Graag uw hulp,

Djoties

Sub Macro1()
'
' Macro1 Macro
'




Dim wsFrom As Worksheet, wsTo As Worksheet
Application.ScreenUpdating = False


'Open eerste bestand
Workbooks.Open ("C:\Documents and Settings\Mijn Documenten\test TST Tussenbestand tijdschrijven.xls ") 'Bronbestand
ThisWorkbook.Activate


Set wsFrom = Workbooks("test TST Tussenbestand tijdschrijven.xls").Worksheets("blad1") 'Bronwerkblad
Set wsTo = Workbooks("Nacalculatie berekening.xls").Worksheets("Blad1") 'Doelwerkblad

'filter zetten op Bronbestand
Windows("test TST Tussenbestand tijdschrijven.xls").Activate
Selection.AutoFilter Field:=3, Criteria1:=Workbooks("Nacalculatie berekening.xls").Sheets("blad1").Range("a1")

wsFrom.Range("A2:Q" & wsFrom.Cells(Rows.Count, 1).End(xlUp).Row).Copy 'kopieren vanuit Bronbestand
wsTo.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
[a1].Select 'naar Doelwerkblad

With Application
.CutCopyMode = False
.ScreenUpdating = True

End With
Range("A1").Select
Workbooks("test TST Tussenbestand tijdschrijven.xls").Close False

'open tweede bestand
'nog nader bepalen


End Sub

 

[cow18]

zo zie ik het tussenstuk, maar ik heb het niet kunnen testen

  Set wsfrom = Workbooks("test TST Tussenbestand tijdschrijven.xls").Worksheets("blad1")  'Bronwerkblad
  Set wsto = Workbooks("Nacalculatie berekening.xls").Worksheets("Blad1")  'Doelwerkblad

  With wsfrom
    If .AutoFilterMode = False Then MsgBox "geen filter actief": Exit Sub
    Set Filterbereik = .Range(.AutoFilter.Range.Address)   'bereik waarop filter nu werkt
    Filterbereik.AutoFilter Field:=3, Criteria1:=wsto.Range("a1")      'nieuwe filtervoorwaarde
    If Filterbereik.Columns(1).SpecialCells(xlVisible).Count = 1 Then  '1e rij blijft altijd staan, dus minstens 1 altijd zichtbaar, maar zijn er nog meer ?
      MsgBox "na filteren is er niets overgebleven"
    Else
      .UsedRange.Offset(1).Columns("A:Q").SpecialCells(xlVisible).Copy  'kopieren vanuit Bronbestand
      wsto.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    End If
  End With

 

[Djoties]

Melding!!!

Mijn dank voor je hulp.

Werkt nu prima!!!

Alleen krijg ik nog een melding van:

Er is een grote hoeveelheid informatie op het klembord. Wilt u deze informatie in een ander document kunnen opslaan?

Zou mooi zijn als deze melding niet meer te zien krijgt.

Mvrgr

 

[cow18]

zet voor je close "application.displayalerts=false" en er na hetzelfde maar true

 

[Djoties]

Dat is mooi!!!!

Heel erg bedankt.

Wellicht weet je ook het volgende?
Ik zou graag nog een tweede filter argument willen gebruiken.
Nu staat 1 in cel a1
de volgende zou ik dus in a2 willen inzetten.

En is het mogelijk dat bij het openen van het bestand eerst filter wordt afgehaald en dan weer erop (reden hiervoor is dat iemand anders wellicht het bestand opgeslagen kan hebben met een ander filter kolom).

M.vr.gr.