• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Code voor meerdere tabbladen

Status
Niet open voor verdere reacties.
danny147

danny147

Terugkerende gebruiker
Lid geworden
29 apr 2007
Berichten
4.744
Beste,

Heb volgende code voor gegevens op te vragen, enkel voor Tabblad 1
Zou deze willen uitbreiden tot 11 tabbladen (Blad1 t.e.m. Blad11)

Code: 
Sub Zoeken_LK()

Dim x As Range

For Each x In Sheets(1).Range("A20:A500")
If Left(x, 2) = LK Or Left(C, 1) = S Then
x.Copy Destination:=Worksheets("Systeem").Range("AN500").End(xlUp).Offset(1, 0)
End If
Next x

End Sub

Hier wat geprobeerd maar krijg foutmelding bij Next I

Code: 
Sub Zoeken_LK()

Dim x As Range
Dim WS_Count As Integer
Dim I As Integer

WS_Count = Worksheets("Blad1").Count

For I = 1 To WS_Count
If WS_Count < 12 Then
'For Each x In Sheets(1).Range("A20:A500")
For Each x In Range("A20:A500")
If Left(x, 2) = LK Or Left(C, 1) = S Then
x.Copy Destination:=Worksheets("Systeem").Range("AN500").End(xlUp).Offset(1, 0)
End If
Next I
Next x

End Sub
 
Die code steekt naar mijn mening dusdanig raar in elkaar dat je er een voorbeeld document bij moet plaatsen.
 
Laatst bewerkt:
Danny,

draai de Next I en Next X eens om....
 
Beste edmoor,

Heb geprobeerd het in een bestandje te steken :d

Ondertussen ook wat aan het zoeken en volgende in elkaar gestoken
Deze werkt goed, misschien heb jij hier een ander mening over ?

Code: 
Sub Zoeken_LK()

If ActiveSheet.Name <> "Blad1" Then
MsgBox "U moet de code starten vanaf Tabblad Blad1", vbInformation + vbOKOnly, "Loopkraan gegevens:"
Exit Sub
Else
End If

Dim x As Range
Dim WS_Count As Integer
Dim I As Integer

WS_Count = ThisWorkbook.Worksheets.Count

For I = 1 To WS_Count
If I < 12 Then
For Each x In Sheets(I).Range("A20:A38")
If Left(x, 2) = "LK" Or Left(x, 1) = "S" Then
x.Copy Destination:=Worksheets("Systeem").Range("AN500").End(xlUp).Offset(1, 0)
End If
Next x
End If
Next I

End Sub
 

Bijlagen

  • Meerdere tabbladen.xlsm
    26,8 KB · Weergaven: 47
1)Je kunt natuurlijk ook for each gebruiken met de sheets natuurlijk.
2) als je toch een numbered loop gebruikt doe dan: for i = 1 to 11. en niet een of andere vage IF statement. die is onnodig en maakt onderhoud veel moeilijker.
 
Beste wampier :d

Bedankt voor je bijdrage, wordt dan dit:

Code: 
Sub Zoeken_LK()

If ActiveSheet.Name <> "Ma Vm + Dag" Then
MsgBox "U moet de code starten vanaf Tabblad Ma Vm + Dag", vbInformation + vbOKOnly, "Loopkraan gegevens:"
Exit Sub
Else
End If

Dim x As Range
Dim I As Integer

For I = 1 To 11
For Each x In Sheets(I).Range("A20:A38")
If Left(x, 2) = "LK" Or Left(x, 1) = "S" Then
x.Copy Destination:=Worksheets("Systeem").Range("AN500").End(xlUp).Offset(1, 0)
End If
Next x
Next I

End Sub
 
Die Dim opdrachten zijn in dit geval niet nodig. Gebruik wel inspringpunten:
Code: 
Sub Zoeken_LK()
    If ActiveSheet.Name <> "Ma Vm + Dag" Then
        MsgBox "U moet de code starten vanaf Tabblad Ma Vm + Dag", vbInformation + vbOKOnly, "Loopkraan gegevens:"
        Exit Sub
    End If

    For I = 1 To 11
        For Each x In Sheets(I).Range("A20:A38")
            If Left(x, 2) = "LK" Or Left(x, 1) = "S" Then
                x.Copy Destination:=Worksheets("Systeem").Range("AN500").End(xlUp).Offset(1, 0)
            End If
        Next x
    Next I
End Sub

Dat maakt het leesbaarder en zie je ook direct welke Next bij welke For hoort etc.
 
Danny,

Wat een waardeloos voorbeeld. Dit komt helemaal niet overeen met het bestand waarin je werkt.
In dit geval kun je nl. het eenvoudigst advancedfilter gebruiken.
Alleen in zo'n leeg geval als door jou hier geplaatst is dat onmogelijk. Hou de helpers svp. niet voor de gek.
In de richtlijnen voor dit forum wordt gevraagd om een representatief voorbeeldbestand.
 
Bedankt allen voor de opmerkingen en goede raad :thumb:

@snb, terechte opmerking, maar het bestandje loopt nu al op tot 500Kb om het hier te plaatsen.
 
Je hoeft maar 1 werkblad met kolom A en B te plaatsen voor een representatief beeld.
 
Beste,

Nog een vraagje...

Heb nog wat code bijgeplaatst om te filteren tussen datum van aanmaak bestandje tot op heden
Zo kunnen wij zien welke orders er zijn aangemaakt en die we over het hoofd hebben gezien.

Bij aangepast filteren, filtert hij op >= 2/4/2018 (cel A2) --> dit lukt

Tweede filter, filtert hij op functieplaatsen
Deze heb ik aangemaakt met een dynamisch bereik "Functieplaatsen"
Deze doet het niet, hij moet alle functieplaatsen nemen in het bereik maar met een * erachter (filter bevat)

Kunnen jullie eens kijken waar het fout is gelopen bij het schrijven van mijn code
Fout zit in regel

Code: 
ActiveSheet.Cells(1).CurrentRegion.AutoFilter Field:=15, Criteria1:=(zCrit), Operator:=xlAnd

Heb veel info en tabbladen weggehaald uit bestaand bestandje
Heb blokken niet actief geplaatst zodat de gegevens in tabblad Output aanwezig blijven.
 

Bijlagen

  • Meerdere tabbladen.xlsm
    500,9 KB · Weergaven: 36
Laatst bewerkt:
Beste,

Is er een mogelijkheid om dit op deze manier uit te voeren
of
moet ik voor iedere functieplaats een filter laten lopen en de gegevens apart laten overschrijven naar een ander tabblad ?
 
Beste,

Hoe kan ik onderstaande code omschrijven zodat de filter "Bevat" wordt of is er een Operator hiervoor ?

Code: 
For I = 1 To Sheets("Systeem").Range("AQ2").Value

    With Sheets("Output").Activate
        ActiveSheet.Cells(1).CurrentRegion.AutoFilter Field:=15, Criteria1:=Sheets("Systeem").Range("AO" & I + 1), Operator:=xlAnd
        Range("A1").CurrentRegion.Copy Destination:=ThisWorkbook.Sheets("Orders na opmaakdatum").Range("A500").End(xlUp).Offset(1, 0)

    End With

Next I
 
ZO?

Code: 
For I = 1 To Sheets("Systeem").Range("AQ2").Value
[COLOR="#FF0000"]zoekwaarde = "*" & Sheets("Systeem").Range("AO" & I + 1) &"*"[/COLOR]
    With Sheets("Output").Activate
        ActiveSheet.Cells(1).CurrentRegion.AutoFilter Field:=15, Criteria1:=[COLOR="#FF0000"]zoekwaarde[/COLOR], Operator:=xlAnd
        Range("A1").CurrentRegion.Copy Destination:=ThisWorkbook.Sheets("Orders na opmaakdatum").Range("A500").End(xlUp).Offset(1, 0)

    End With

Next I
 
Beste Haije

Bedankt dit werkt perfect, enkel nog wat problemen met het wegschrijven van bereiken na filteren
In plaats van volgende regel wil ik enkel het bereik C2:C10 hebben

Code: 
Range("A1").CurrentRegion.Copy Destination:=ThisWorkbook.Sheets("Orders na opmaakdatum").Range("A500").End(xlUp).Offset(1, 0)

Heb deze geprobeerd maar geeft foutmelding

Code: 
Dim MijnRange As Range

    For i = 1 To Sheets("Systeem").Range("AQ2").Value
    
        zoekwaarde = Sheets("Systeem").Range("AO" & i + 1) & "*"

        With Sheets("Output").Activate
    
            ActiveSheet.Cells(1).CurrentRegion.AutoFilter Field:=15, Criteria1:=zoekwaarde, Operator:=xlAnd
        
            Set MijnRange = Range("A2:A7000").SpecialCells(xlCellTypeVisible).Resize(3, 10)
                  MijnRange.Copy Destination:=ThisWorkbook.Sheets("Orders na opmaakdatum").Range("A500").End(xlUp).Offset(1, 0)
            
        Sheets("Orders na opmaakdatum").Range("A1:R1").Copy Destination:=ThisWorkbook.Sheets("Orders na opmaakdatum").Range("C500").End(xlUp).Offset(2, -2)
        
        End With
    Next i
 
Code: 
Sub M_snb()
  sn= Sheets("Systeem").Range("AO2").resize(Sheets("Systeem").Range("AQ2").Value)

  With Sheets("Output").Cells(1).CurrentRegion
    For j = 1 To ubound(sn)
     .AutoFilter 15, sn(j,1) & "*"
      .Copy Sheets("Orders na opmaakdatum").cells(rows.count,1).end(xlup).offset(1)
    next
  end with
 End Sub
 
Laatst bewerkt:
Beste snb,

Krijg foutmelding op volgende regel:

Code: 
.Copy Sheets("Orders na opmaakdatum").Cells(Rows.Count, 1).Offset(1)

In het verleden heb je het volgende eens doorgestuurd en moet op dezelfde manier opgebouwd worden (wat kolommen betreft) maar krijg het niet voor elkaar

Code: 
            .AutoFilter 15, Blad15.Cells(strTwo, 2) & "*"
                sn = .Cells(1).CurrentRegion
                     ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2))
                       For ii = 2 To UBound(sn)
                        If Not .Rows(ii).Hidden Then
                           
                      'For jj = 1 To sn(ii, 13)
                       n = n + 1
                         For j = 1 To UBound(sn, 2)
                          arr2(n, 1) = sn(ii, 3)
                          arr2(n, 2) = sn(ii, 4)
                          arr2(n, 3) = sn(ii, 6)
                          arr2(n, 4) = sn(ii, 11)
                          arr2(n, 9) = sn(ii, 9)
                          arr2(n, 10) = sn(ii, 8)
                          arr2(n, 12) = sn(ii, 13)
                          arr2(n, 13) = sn(ii, 14)
                          arr2(n, 14) = sn(ii, 2)
                        Next j
                     'Next jj
                    End If
                  
                  Next ii
 
Als je zegt een foutmelding te krijgen vertel er dan ook bij welke dat is.
 
Beste,

Fout = 1004 tijdens toepassing
Door de toepassing of door object gedefinieerde fout
 
Laatst bewerkt:
Code: 
Sheets("Orders na opmaakdatum").Cells(Rows.Count, 1).[COLOR="#FF0000"]end(xlup)[/COLOR].Offset(1)
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan