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

Offerte maken door in tabblad data de hoeveelheid in te voeren

Status
Niet open voor verdere reacties.
HSV,

ja,.... alleen NIET als module invoegen.... Maar IN de "VBA-pagina" van het tabblad 'Data'.

Ik heb vaker gelezen dat 'sheet("offerte").activate' "not done" is..... Waarom eigenlijk?
 
Dan flikkert het beeld van de ene naar de ander pagina, is ook niet nodig om naar een ander blad te gaan om alleen maar gegevens weg te schrijven.
 
Toch nog een foutmelding

Ik weet niet of ik een vraag überhaupt kan/mag her-openen, maar ik probeer het.....

De oplossing werkt goed, maarrrrrr dient alleen te werken voor cellen gevuld zijn met getallen.
Een paar cellen binnen het bereik hebben een formule waardoor in een ander deel van de sheet "vert.zoeken()"-opties niet (meer) functioneren.
Ik heb in de loop getracht " and sv = isnumeric" of integer geprobeerd, maar dit lukt me dus niet.
Dus, de voorwaardelijkheid binnen de loop moet zijn " > 0 and sv.format = getal ".

Dit is de code
Code: 
Private Sub Worksheet_Activate()
Dim sv, area As Range, i As Long, n As Long
sv = Sheets("data").Range("c7:q37")
ReDim arr(UBound(sv) * 2, 5)
For Each area In Sheets("data").Range("c7:h37, l7:Q37").Areas
  sv = area
    For i = 1 To UBound(sv)
       If sv(i, 1) > 0 Then
          arr(n, 0) = sv(i, 2)
          arr(n, 1) = sv(i, 3)
          arr(n, 2) = sv(i, 4)
          arr(n, 3) = sv(i, 5)
          arr(n, 4) = sv(i, 1)
          arr(n, 5) = sv(i, 6)
        n = n + 1
       End If
     Next i
 Next area
   Range("b4").CurrentRegion.Offset(, 1).ClearContents
   Range("b4").Resize(n, 6) = arr
End Sub

Heeft iemand een idee?
 
Iets aangepast.

Select is overbodig.

Er staat ook wat onzin in als tekst gemarkeerd; mijn commentaar staat er achter.

Code: 
Public Sub copy2Offerte()
Dim sv, area As Range, i As Long, n As Long
Dim myX As String
sv = Sheets("Data").Range("c3:q33")
 With Sheets("Offerte")
    myX = MsgBox("""Data""-data wordt gekopiëerd naar ""Offerte" & vbCr & vbCr _
    & "                                       Wilt u doorgaan?" _
    , vbYesNo, "                                          LEES DIT.....!")
            
    If myX = vbNo Then
        MsgBox "De macro is gestopt. Pas de data eventueel aan.", , "    De Macro is gestopt!" & vbCr & vbCr
        Exit Sub
    End If
    
    If myX = vbYes Then
        'Origineel éérst opslaan (zonder bevestiging)
        ThisWorkbook.Save
        
   
'MsgBox "Alle ingevulde cellen van tabblad ""Voorblad nieuw-""" & vbCr & vbCr & _
'            "kolommen ""C"" en ""L"" worden gekopieerd naar ""Matrix Isah""." & vbCr & vbCr & _
'            "Alle voorgaande data wordt in de ""loop"" verwijderd. "
        
        'Kopieer alle data van "Voorblad nieuw"
        ReDim arr(UBound(sv) * 2, 5)
        For Each area In Sheets("Data").Range("c3:h33, l3:Q33").Areas
          sv = area
            For i = 1 To UBound(sv)
               If IsNumeric(sv(i, 1)) And Not IsEmpty(sv(i, 1)) Then
                  arr(n, 0) = sv(i, 2)
                  arr(n, 1) = sv(i, 3)
                  arr(n, 2) = sv(i, 4)
                  arr(n, 3) = sv(i, 5)
                  arr(n, 4) = sv(i, 1)
                  arr(n, 5) = sv(i, 6)
                n = n + 1
               End If
             Next i
         Next area
        
           .Range("a4").CurrentRegion.resize(,6).ClearContents
           If n > 0 Then .Range("a4").Resize(n, 6) = arr
           
'MsgBox "Kopiëren data is KLAAR.....!"
    End If
    
'Na de vulling van Matrix Isah wordt meteen en alleen het tabblad matrix isah opgeslagen  'onzin!!
    Application.Goto .Range("d2")
 End With
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan