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

VB scipts laten aansluiten

Status
Niet open voor verdere reacties.
M

moensk

Gebruiker
Lid geworden
23 jun 2013
Berichten
778
hierbij een gedeelte van mijn script.
probleem
'VBA voor LZV ritten' begint vast op rij 36, op rij 35 wordt een hoofding gekopieerd.
ik wil 35 en 36 vervangen door variabelen waarbij hij kijkt naar de eerste lege rij (cel) na uitvoeren van 'VBA voor bakwagen ritten'
zodat in mijn excel alles mooi aansluit en ik dus geen lege rijen heb voor 35...

Code: 
  'VBA voor bakwagen ritten
For j = 2 To UBound(ar)
    If ar(j, 5) = Sheets("info").Range("D1").Value And ar(j, 2) = "B" And ar(j, 17) = "VRE" Then
        ar1(t, 0) = ar(j, 1)
        ar1(t, 1) = ar(j, 12)
        ar1(t, 2) = ar(j, 6)
        ar1(t, 3) = ar(j, 7)
        ar1(t, 4) = ar(j, 24)
        ar1(t, 5) = ar(j, 27)
        t = t + 1
    End If
Next j
Sheets("info").Cells(3, 1).Resize(UBound(ar1) + 1, UBound(ar1, 2) + 1) = ar1

    'VBA voor LZV ritten
For j = 2 To UBound(aq)
    If aq(j, 5) = Sheets("info").Range("D1").Value And aq(j, 2) = "L" And aq(j, 17) = "VRE" Then
        aq1(z, 0) = aq(j, 1)
        aq1(z, 1) = aq(j, 12)
        aq1(z, 2) = aq(j, 6)
        aq1(z, 3) = aq(j, 7)
        aq1(z, 4) = aq(j, 24)
        aq1(z, 5) = aq(j, 27)
        z = z + 1
    End If
Next j
Sheets("info").Cells(36, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1

    'hoofdingen vastleggen
vv = Range("B2:F2")
Range("B35").Resize(1, 5) = vv
 
een volledige code en een voorbeeldbestand zou handig zijn, maar hier een poging:

Code: 
With Sheets("info")
  'VBA voor bakwagen ritten
For j = 2 To UBound(ar)
    If ar(j, 5) = .Range("D1").Value And ar(j, 2) = "B" And ar(j, 17) = "VRE" Then
        ar1(t, 0) = ar(j, 1)
        ar1(t, 1) = ar(j, 12)
        ar1(t, 2) = ar(j, 6)
        ar1(t, 3) = ar(j, 7)
        ar1(t, 4) = ar(j, 24)
        ar1(t, 5) = ar(j, 27)
        t = t + 1
    End If
Next j
    .Cells(3, 1).Resize(UBound(ar1) + 1, UBound(ar1, 2) + 1) = ar1

    'VBA voor LZV ritten
For j = 2 To UBound(aq)
    If aq(j, 5) = .Range("D1").Value And aq(j, 2) = "L" And aq(j, 17) = "VRE" Then
        aq1(Z, 0) = aq(j, 1)
        aq1(Z, 1) = aq(j, 12)
        aq1(Z, 2) = aq(j, 6)
        aq1(Z, 3) = aq(j, 7)
        aq1(Z, 4) = aq(j, 24)
        aq1(Z, 5) = aq(j, 27)
        Z = Z + 1
    End If
Next j
    .Cells(.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1
End With

    'hoofdingen vastleggen
vv = Range("B2:F2")
Range("B35").Resize(1, 5) = vv
 
hierbij een groter gedeelte van het script
ik krijg volgende foutmelding "compileerfout (ongeldige of niet-gekwalificeerde verwijzing)" op Range bij .Cells(.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1

Code: 
 ' Find the last non-blank cell in column A(5)
    lRow = Sheets("data").Cells(Rows.Count, 5).End(xlUp).Row
    
For i = 2 To lRow
    If Sheets("data").Cells(i, 9).Value <> "" Then
    For y = 2 To lRow
        If ((Sheets("data").Cells(y, 5).Value = Sheets("data").Cells(i, 5).Value) And (Sheets("data").Cells(y, 13).Value = Sheets("data").Cells(i, 13).Value)) Then
          Sheets("data").Cells(y, 9).Value = Sheets("data").Cells(i, 9).Value
        End If
    Next y
    End If
Next i

[A3:Z2000].ClearContents
Dim ar, ar1, j As Long, k As Long, z As Long
Dim at, at1, t As Long
Dim aq, aq1, q As Long
Dim ao, ao1, o As Long
Dim ax, ax1, x As Long
Dim av, av1, v As Long
Dim sv, b As Long, c00 As String, datum As Date

Dim R As Range

    ' selectie voor bakwagens
ar = Sheets("data").Cells(1).CurrentRegion
ReDim ar1(UBound(ar), 7)
    'selectie voor trekkers
at = Sheets("data").Cells(1).CurrentRegion
ReDim at1(UBound(at), 7)
    'selectie voor LZV
aq = Sheets("data").Cells(1).CurrentRegion
ReDim aq1(UBound(aq), 6)
    'selectie voor gdp wagens
ao = Sheets("data").Cells(1).CurrentRegion
ReDim ao1(UBound(ao), 6)
    ' selectie voor shuttle chauffeurs
ax = Sheets("data").Cells(1).CurrentRegion
ReDim ax1(UBound(ax), 6)


    'VBA voor bakwagen ritten
For j = 2 To UBound(ar)
    If ar(j, 5) = Sheets("info").Range("D1").Value And ar(j, 2) = "B" And ar(j, 17) = "VRE" Then
        ar1(t, 0) = ar(j, 1)
        ar1(t, 1) = ar(j, 12)
        ar1(t, 2) = ar(j, 6)
        ar1(t, 3) = ar(j, 7)
        ar1(t, 4) = ar(j, 24)
        ar1(t, 5) = ar(j, 27)
        t = t + 1
    End If
Next j
Sheets("info").Cells(3, 1).Resize(UBound(ar1) + 1, UBound(ar1, 2) + 1) = ar1


    'VBA voor LZV ritten
For j = 2 To UBound(aq)
    If aq(j, 5) = Sheets("info").Range("D1").Value And aq(j, 2) = "L" And aq(j, 17) = "VRE" Then
        aq1(z, 0) = aq(j, 1)
        aq1(z, 1) = aq(j, 12)
        aq1(z, 2) = aq(j, 6)
        aq1(z, 3) = aq(j, 7)
        aq1(z, 4) = aq(j, 24)
        aq1(z, 5) = aq(j, 27)
        z = z + 1
    End If
Next j
'Sheets("info").Cells(36, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1
    .Cells(.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1
End With
 
sjonr, kan ik u soms rechtstreeks mailen ?
in het bestand staan namelijk bedrijfsgegevens die ik niet kan delen
 
Nee, ook aan mij persoonlijk mag je deze gegevens niet verstrekken.
 
Aan halve code hebben we niet zoveel. Waar staat With sheets(??)
 
oke - ik kijk wat ik kan aanpassen zodat het toch nog werkend is en ik kan posten
 
je zou kunnen doorborduren op de variabele van de vorige array:

Code: 
Sheets("info").Cells(t + 4, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1
Range("B" & t + 3).Resize(1, 5) = vv
Sheets("info").Range("A" & t + 3).Value = "LZV"

Volgorde van de onderdelen kan beter trouwens :)
 
Sjorn,
thanks, werkt bijna correct
kan u even na printscreentje kijken waar het nog fout gaat
alvast bedankt

help.jpg
 
aan een printscreen zie ik alleen 'dat' fout gaat, niet waarom.

plaats even de door jouw aangepaste code, bij voorkeur in een bestand. Deja vu?
 
Sjorn,
ik krijg geen fout melding, u code werkt super
alleen is er 1 lege regel nog en plaatst hij in die lege regel het woord "lzv"

PHP: 
Sheets("info").Cells(t + 4, 1).Resize(UBound(aq1) + 1, UBound(aq1, 2) + 1) = aq1
Range("B" & t + 3).Resize(1, 5) = vv
Sheets("info").Range("A" & t + 3).Value = "LZV"
 
ik weet niet of je leest wat ik schrijf, maar ik zie graag het bestand met de door jouw aangepaste code. Val een beetje in herhaling ben ik bang.
 
Waarom werk je niet vanuit 1 array? Als je de volgorde van de kolommen gelijk goed zet dan hoef je niet eens te husselen. Als basis

Code: 
Sub VenA()
  ar = Sheets("Data").ListObjects(1).DataBodyRange
  k = Split("1 12 7 6 24 27 2 17 13")
  With Sheets("info")
    .UsedRange.Offset(2).ClearContents
    ReDim ar1(UBound(ar), 8)
    For j = 1 To UBound(ar)
      If ar(j, 5) = d Then
        For jj = 0 To 8
          ar1(t, jj) = ar(j, k(jj))
        Next jj
        t = t + 1
      End If
    Next j
  End With
End Sub
 
Hoe kom je eigenlijk aan dit breiwerk en begrijp je wel wat je aan het doen bent? Het is een samenraapsel van?
 
VenA,
klopt dat het een breiwerk is. ben al blij dat alles werkt, de gewenste info samengevoegd wordt.
heb geen VBA achtergrond dus veel puzzel werk :)
 
Bedenk dan eerst wat je wil.

Het hard coderen zoals
Code: 
"E2135" And at(j, 13) <> "E1065" And at(j, 13) <> "E2569" And at(j, 13) <> "E1915" And at(j, 13) <> "E2532" And at(j, 13) <> "E2516" And at(j, 13) <> "E2490" And at(j, 13) <> "E2260" And at(j, 13) <> "E2220"
"E2135" Or ax(j, 13) = "E1065" Or ax(j, 13) = "E2532" Or ax(j, 13) = "E1915" Or ax(j, 13) = "E2569" Or ax(j, 13) = "E2516" Or ax(j, 13) = "E2490" Or ax(j, 13) = "E2260" Or ax(j, 13) = "E2220")
Lijkt mij niet erg handig. Verder kan je je eens verdiepen in de AVG ook wel GDPR. Een berijf met 300 medewerkers zal ook wel een IT afdelingen hebben die dit soort zaken voor je kan maken.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan