• 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.

type komen niet overeen (VBA)

Status
Niet open voor verdere reacties.
M

moensk

Gebruiker
Lid geworden
23 jun 2013
Berichten
712
aan de hand van datum (B1) & wagennr (B2) moet hij gegevens ophalen uit tabblad "data"
en deze plakken in tabblad "Controle" vanaf rij 6
hierbij script en voorbeeld
kan iemand hier even naar kijken
Code: 
Sub Controle()

    Dim ar, ar1 As Long
    Dim j, t As Long
    Dim sr As Long
    Dim c00 As String
    
    ar = Sheets("data").ListObjects(1).DataBodyRange
    sr = 6
    
    With Sheets("controle")
        .Range("A" & sr & ":M600").ClearContents
        For j = 1 To UBound(ar)
            If ar(j, 1) = .Range("B1").Value And ar(j, 5) = .Range("B2").Value Then
            c00 = c00 & j & "|"
            t = t + 1
        End If
    Next j
    .Cells(sr, 1).Resize(t, 11) = Application.Transpose(Application.Index(ar, Split(c00, "|"), Application.Transpose(Array(59, 3, 8, 11, 15, 18, 55, 56, 21, 32, 33))))
        With .Cells(sr - 1, 1).CurrentRegion
            .Sort .Cells(1, 1), , .Cells(1, 3), , , , , x1Yes
        End With
    End With
End Sub
 

Bijlagen

  • Pallet_Controle_test.xlsm
    357,8 KB · Weergaven: 26
Hi,

wagennummer in werkblad "Data" is tekst. geen getal. daarom de foutmelding.
pas je code zo aan:
Code: 
If ar(j, 1) = .Range("B1").Value And [COLOR="#FF0000"]CDbl([/COLOR]ar(j, 5)[COLOR="#FF0000"])[/COLOR] = .Range("B2").Value Then

daarna loopt je code stuk op de samengevoegde cellen in het werkblad Controle (I4:K4).
als je dit verwijderd, loopt je code weer.
 
Als je de headers onderaan je tabel wil hebben waarschijnlijk wel. De controle zou ik andersom doen.
Code: 
If ar(j, 1) = .Range("B1").Value And ar(j, 5) = [COLOR="#FF0000"]CStr([/COLOR].Range("B2").Value[COLOR="#FF0000"])[/COLOR] Then
Of misschien beter
Code: 
If ar(j, 1) = .Range("B1").Value And CStr(ar(j, 5)) = CStr(.Range("B2").Value) Then

Extra controle als een wagen niet ingepland is op een bepaalde datum
Code: 
If t > 0 Then .Cells(sr, 1).Resize(t, 11) =........

Sorteren met deze opmaak waardoor de currentregion niet meer klopt kan ook ook zo.
Code: 
With .Cells(sr - 1, 1).CurrentRegion[COLOR="#FF0000"].Offset(1)[/COLOR]
 
Laatst bewerkt:
Thanks V&A
ga morgen wat experimenteren met u adviezen
vraag : ik krijg wel nog een foutmelding doordat I4 in "controle" een samengevoegde cel is
ik heb sort.cells(1, 1) en (1, 3) al naar (6, 1) en (6, 3) gezet doch dan nog krijg ik foutmelding 1004 hoe kan ik dat oplossen ?
 
Gebruik NOOIT samengevoegde cellen. De aanpassingen die je gedaan hebt kloppen ook niet. Lees eens iets over Currentregion. Is ook te testen door A5 te selecteren en vervolgens op <Ctrl> + a te drukken.
 
Waarom gebruik je geen tabel voor de uitkomst?

Code: 
Sub VenA()
  Dim j As Long, t As Long, ar
  ar = Sheets("data").ListObjects(1).DataBodyRange
  With Sheets("controle")
    For j = 1 To UBound(ar)
      If ar(j, 1) = .Range("B1").Value And CStr(ar(j, 5)) = CStr(.Range("B2").Value) Then
        c00 = c00 & j & "|"
        t = t + 1
      End If
    Next j
    
    With .ListObjects(1)
      If .ListRows.Count Then .DataBodyRange.Delete
      If t > 0 Then
        .ListRows.Add.Range.Resize(t, 11) = Application.Transpose(Application.Index(ar, Split(c00, "|"), Application.Transpose(Array(59, 3, 8, 11, 15, 18, 55, 56, 21, 32, 33))))
        .Range.Sort .Range.Cells(1, 1), , .Range.Cells(1, 3), , , , , x1Yes
      End If
    End With
  End With
End Sub
 

Bijlagen

  • Pallet_Controle_test.xlsm
    361,1 KB · Weergaven: 33
V&A, alle aanpassingen doorgevoerd en ook een tabel van gemaakt, ziet er netjes uit nu :)
in kolom I / J / K staan getallen hoe kan ik zorgen dat de waardes bv rood worden indien niet alle getallen gelijk zijn ?
 
heb een 2de script gemaakt doch de tabel van 2de script verspringt van rij als ik andere wagen kies (B2) en script 1 uitvoer
hoe kan ik de 2de tabel (ListObjects(2)) vast zetten op rij 30 ?
kort voorbeeld in bijlage

Code: 
Sub VenA()
  Dim j As Long, t As Long, ar
  ar = Sheets("data").ListObjects(1).DataBodyRange
  With Sheets("controle")
    For j = 1 To UBound(ar)
      If ar(j, 1) = .Range("B1").Value And CStr(ar(j, 5)) = CStr(.Range("B2").Value) Then
        c00 = c00 & j & "|"
        t = t + 1
      End If
    Next j
    
    With .ListObjects(1)
      If .ListRows.Count Then .DataBodyRange.Delete
      If t > 0 Then
        .ListRows.Add.Range.Resize(t, 14) = Application.Transpose(Application.Index(ar, Split(c00, "|"), Application.Transpose(Array(59, 3, 8, 11, 15, 18, 55, 56, 21, 32, 33, 31, 42, 43))))
        .Range.Sort .Range.Cells(1, 1), , .Range.Cells(1, 3), , , , , x1Yes
      End If
    End With
  End With
End Sub


Sub boordcomputer()
  Dim j As Long, t As Long, ar
  ar = Sheets("boordcomputer").ListObjects(1).DataBodyRange
  With Sheets("controle")
    For j = 1 To UBound(ar)
      If ar(j, 1) = .Range("B1").Value And CStr(ar(j, 5)) = CStr(.Range("B2").Value) Then
        c00 = c00 & j & "|"
        t = t + 1
      End If
    Next j
    
    With .ListObjects(2)
      If .ListRows.Count Then .DataBodyRange.Delete
      If t > 0 Then
        .ListRows.Add.Range.Resize(t, 8) = Application.Transpose(Application.Index(ar, Split(c00, "|"), Application.Transpose(Array(19, 3, 8, 10, 14, 14, 17, 18))))
        .Range.Sort .Range.Cells(1, 1), , .Range.Cells(1, 3), , , , , x1Yes
      End If
    End With
  End With
End Sub
 

Bijlagen

  • Pallet_Controle_test.xlsm
    64,2 KB · Weergaven: 24
Even knippen en plakken. Kan je zelf ook wel vinden en opnemen met een macro.

Tussen de twee End With's in de sub VenA
Code: 
.ListObjects(2).Range.Cut .Cells(30, 1)
 
VenA - werkt bedankt
doch nu krijg ik steeds een blauwe lijn (rij 39) ergens in de tabel, zie foto in bijlage
enig idee waar dit aan ligt ? het is geen vaste rij het verschilt telkens

2019-07-11_11-21-08.jpg
 
Dat heeft te maken met de opmaak die ergens onthouden wordt. De tabel heb ik geconverteerd naar waarden. Vervolgens alle opmaak weggehaald en er weer een tabel van gemaakt. Dit lijkt goed te gaan.
 

Bijlagen

  • Pallet_Controle_test (3).xlsm
    65,5 KB · Weergaven: 28
Ook.
Code: 
Sub hsv()
Dim sq, s0 As String
  Sheets("data").ListObjects(1).DataBodyRange.Columns(1).Name = "br"
  With Sheets("controle")
    s0 = Join(Filter([transpose(if((br=controle!b1)*(offset(br,,4)=controle!B2),row(br),"~"))], "~", 0), "|") & "|"
     With .ListObjects(1)
      If .ListRows.Count Then .DataBodyRange.Delete
      If Len(s0) > 0 Then
       sq = Split(s0, "|")
        .ListRows.Add.Range.Resize(UBound(sq), 14) = Application.Transpose(Application.Index(Sheets("data").ListObjects(1).Range, sq, Application.Transpose(Array(59, 3, 8, 11, 15, 18, 55, 56, 21, 32, 33, 31, 42, 43))))
        .Range.Sort .Range.Cells(1, 1), , .Range.Cells(1, 3), , , , , 1
      End If
    End With
    .ListObjects(2).Range.Cut .Cells(30, 1)
  End With
End Sub
 
VenA ik loop toch nog tegen een probleem aan.
Heb de tabel geconverteerd... zoals u aangaf.
in bijlage heb ik één wagen en één dag laten staan als voorbeeld.
als ik op "zoek" druk dan past hij de hoofding van de 2de tabel aan "rij 30"
ik heb u voorbeeld gedownload en daar gebeurd dat niet bij, enig idee waar dit kan aan liggen ?
 

Bijlagen

  • Pallet_Controle.xlsm
    57,4 KB · Weergaven: 25
HSV hebt gij soms een oplossing voor mij probleem met de opmaak van de tabel ?
 
Het laatste stukje.

Code: 
If Len(s0) > 0 Then
       sq = Split(s0, "|")
        .Parent.ListObjects(2).Range.Cut .Parent.ListObjects(1).Range.Cells(1).Offset(UBound(sq) + 10)
        .ListRows.Add.Range.Resize(UBound(sq), 14) = Application.Transpose(Application.Index(Sheets("data").ListObjects(1).Range, sq, Application.Transpose(Array(59, 3, 8, 11, 15, 18, 55, 56, 21, 32, 33, 31, 42, 43))))
        .Range.Sort .Range.Cells(1, 1), , .Range.Cells(1, 3), , , , , 1
End If
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan