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

Gegevens uit meerdere velden kopieren dmv VBA

Status
Niet open voor verdere reacties.
W

wilma671

Gebruiker
Lid geworden
22 jun 2017
Berichten
16
Goedemiddag,

Ik ben al een tijdje aan het stoeien met VBA maar kom er niet uit. Ik wil namelijk gegevens uit verschillende cellen kopieren naar een nieuw tabblad dmv VBA. het probleem zit hem in dat ik vanuit 1 cel maar 1 resultaat heb en vanuit andere cellen meerderen.

Nu wil ik dat de 1e resultaat doorgetrokken wordt zodat hij even lang is dan de andere cellen en dat vervolgens de volgende reeks eronder komen te staan. Het is een totaal overzicht dus hij mag de gegevens niet overschrijven. Wat ik wil is moeilijk uit te leggen daarom heb ik een voorbeeld gemaakt, misschien dat het dan wat duidelijker is.

Weet iemand of dit via VBA te realiseren is?
 

Bijlagen

Maak een realistisch voorbeeldbestand met de verwachte uitkomst. Als je met VBA aan het stoeien geweest bent waarom staat de code er dan niet in?
 
Ik heb nogmaals een voorbeeld bestand geplaatst misschien is het nu iets duidelijk. Onderstaande code had ik maar werkt niet.

Code: 
Sub macro1()
' Macro1 Macro
Application.ScreenUpdating = False

  Sheets("Factuur").Range("B6").Copy
  Sheets("Totale verkoop").Range("A" & Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial xlValues
  
  Sheets("Factuur").Range("A12").Copy
  Sheets("Totale verkoop").Range("B" & Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial xlValues
  
  Sheets("Factuur").Range("B12").Copy
  Sheets("Totale verkoop").Range("C" & Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial xlValues
  
  Sheets("Factuur").Range("C12").Copy
  Sheets("Totale verkoop").Range("D" & Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial xlValues
  
  Sheets("Factuur").Range("D12").Copy
  Sheets("Totale verkoop").Range("E" & Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial xlValues
 
  Sheets("Factuur").Range("D4").Copy
  Sheets("Totale verkoop").Range("F" & Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial xlValues

  Sheets("Factuur").Select
Range("B6").Select
MsgBox "Gegevens gekopieerd. "
End Sub
 

Bijlagen

Als je bestanden met macro's hebt, dan moet je deze opslaan als .xlsm of .xlsb. Anders moet je de macro steeds opnieuw maken.
Probeer het zo maar eens
Code: 
Sub VenA()
  With Sheets("Factuur")
    c00 = .Range("B6").Value
    c01 = .Range("D4").Value
    ar = .Range("A11").CurrentRegion
  End With
  If UBound(ar) > 1 Then ReDim ar1(UBound(ar), 5) Else Exit Sub
  For j = 2 To UBound(ar)
    ar1(j - 2, 0) = c00
    ar1(j - 2, 1) = Format(ar(j, 1), "mm-dd-yyyy")
    ar1(j - 2, 2) = ar(j, 2)
    ar1(j - 2, 3) = ar(j, 3)
    ar1(j - 2, 4) = ar(j, 4)
    ar1(j - 2, 5) = c01
  Next j
  Sheets("Totale verkoop").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), 6) = ar1
End Sub
 
Laatst bewerkt:
De code is bijna goed zie printscreen.Knipsel.PNG
Zou jij de code iets kunnen uitleggen zodat ik eventueel zelf aanpassingen kan maken.
 
Wat moet ik aan het plaatje kunnen zien dan? Om de code te begrijpen kan je er eens stap voor stap doorheen lopen met <F8> in de VB-editor. Zet het scherm Locals aan dan kan je stap voor stap zien welke variabele welke waarde krijgt.
 
Afgelopen week weer bezig geweest met de VBA code om de niet nodige regels te laten verwijderen zoals in boven geplaatst afbeelding is weergegeven.
Nu wil ik deze code :
Code: 
Sheets("Totale verkoop").Select

  ActiveSheet.Range("$A:$F).AutoFilter Field:=2, Criteria1:=Array( _

        "Aan:", "Betalingsconditie:", "Datum", "ibannr:  o.v.v. het factuurnummer", _

        "Wij verzoeken u vriendelijk om het totaalbedrag binnen 30 dagen over te maken op" _

        , "="), Operator:=xlFilterValues

    Selection.SpecialCells(xlCellTypeVisible).Select

    Selection.Delete Shift:=xlUp


Toevoegen aan de bestaande code:

Code: 
Sub VenA()
  With Sheets("Factuur")
    c00 = .Range("B6").Value
    c01 = .Range("D4").Value
    ar = .Range("A11").CurrentRegion
  End With
  If UBound(ar) > 1 Then ReDim ar1(UBound(ar), 5) Else Exit Sub
  For j = 2 To UBound(ar)
    ar1(j - 2, 0) = c00
    ar1(j - 2, 1) = Format(ar(j, 1), "mm-dd-yyyy")
    ar1(j - 2, 2) = ar(j, 2)
    ar1(j - 2, 3) = ar(j, 3)
    ar1(j - 2, 4) = ar(j, 4)
    ar1(j - 2, 5) = c01
  Next j
  Sheets("Totale verkoop").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), 6) = ar1
End Sub

Maar hij blijft maar foutmeldingen geven. Kan iemand mij helpen deze twee code te combineren?
 
Welke foutmelding? Waarom geen voorbeeldbestand?

Misschien zo
Code: 
With Sheets("Totale verkoop").Columns(2)
  .SpecialCells(4).EntireRow.Delete
  .SpecialCells(2, 2).EntireRow.Delete
End With
 
Je kan beter voorkomen dat de 'overige' regels in de tab 'Totale verkoop' terecht komen. Doe eens onderzoek naar currentregion. Met de tip in #6 heb je blijkbaar niets gedaan. Je had dan kunnen zijn dat er veel meer gegevens in ar komen dan noodzakelijk.

Code: 
Sub VenA()
  With Sheets("Factuur")
    c00 = .Range("B6").Value
    c01 = .Range("D4").Value
    ar = .Range("A11").CurrentRegion
  End With
  If UBound(ar) > 1 Then ReDim ar1(UBound(ar), 5) Else Exit Sub
  For j = [COLOR="#FF0000"]11[/COLOR] To UBound(ar) [COLOR="#FF0000"]- 5[/COLOR]
    ar1(j - 2, 0) = c00
    ar1(j - 2, 1) = Format(ar(j, 1), "mm-dd-yyyy")
    ar1(j - 2, 2) = ar(j, 2)
    ar1(j - 2, 3) = ar(j, 3)
    ar1(j - 2, 4) = ar(j, 4)
    ar1(j - 2, 5) = c01
  Next j
  Sheets("Totale verkoop").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), 6) = ar1
End Sub
 
VenA zei:
Met de tip in #6 heb je blijkbaar niets gedaan. Je had dan kunnen zijn dat er veel meer gegevens in ar komen dan noodzakelijk.

Ik heb je tip wel opgevolgd alleen ik ben een beginner met VBA. De codes die jij gebruikt zijn voor mij te vergevorderd en moeilijk te begrijpen.

Ik zie dat hij nu inderdaad de cellen goed pakt alleen begint hij nu pas met "plakken" in het tabblad "totale verkoop" op regel 11.

Volgens mij geeft onderstaande code weer dat hij de waarde van regel 11 moet overnemen en -5 is de laatste 5 regels van de factuur niet.
Code: 
 For j = 11 To UBound(ar) - 5

Dit houd in dat hij tot de laatste regel -5 de naam doortrekt. Hoe kan ik aangeven dat hij tot laatste regel met data moet pakken?
Klik om te vergroten...
 

Bijlagen

Code: 
ar1(j - [COLOR="#FF0000"]11[/COLOR], 0) = c00
idem voor de rest.
 
ik loop tegen hetzelfde probleem aan denk ik ik ben aan het stoeien geweest maar nu


copie gaat van a12 tot a39 ongeveer, maar stel ik zet maar 10 dingen er in, DAn ggebeurt het volgende op het intevoeren blad: de a kolom, daar komt de tekst welke in B6 staat en in de F kolom komt de tekst van uit D4 te staan. komt tekst terwijk niet alle regels gevuld zijn dus moet handmatig deleten dit kan vba ook automatiesc toch ?

help me forum ff.JPG

gr arnaud
 
Tja, als voorbeeldbestanden steeds wijzigen dan zal je je wijzigingen moeten ondervangen.

Code: 
If ar(j,1) <> then
code
end if
 
Sub VenA()
If ar(j,1) <> then
With Sheets("Factuur")
c00 = .Range("B6").Value
c01 = .Range("D4").Value
ar = .Range("A11").CurrentRegion
End With
If UBound(ar) > 1 Then ReDim ar1(UBound(ar), 5) Else Exit Sub
For j = 11 To UBound(ar) - 5
ar1(j - 2, 0) = c00
ar1(j - 2, 1) = Format(ar(j, 1), "mm-dd-yyyy")
ar1(j - 2, 2) = ar(j, 2)
ar1(j - 2, 3) = ar(j, 3)
ar1(j - 2, 4) = ar(j, 4)
ar1(j - 2, 5) = c01
Next j
Sheets("Totale verkoop").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), 6) = ar1
End If
End Sub
Klik om te vergroten...

help me forum ff.JPG

je vorige code toegevoegd maar dat werkt niet helemaal helaas ( doe vast iets niet juist ) :(
 
Zo?
Code: 
Sub VenA()
  With Sheets("Factuur")
    c00 = .Range("B6").Value
    c01 = .Range("D4").Value
    ar = .Range("A11").CurrentRegion
  End With
  If UBound(ar) > 1 Then ReDim ar1(UBound(ar), 5) Else Exit Sub
    
        For j = 11 To UBound(ar) - 5
         If ar(j, 1) <> "" Then
            ar1(j - 11, 0) = c00
            ar1(j - 11, 1) = Format(ar(j, 1), "mm-dd-yyyy")
            ar1(j - 11, 2) = ar(j, 2)
            ar1(j - 11, 3) = ar(j, 3)
            ar1(j - 11, 4) = ar(j, 4)
            ar1(j - 11, 5) = c01
         End If
        Next j
    
  Sheets("Totale verkoop").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), 6) = ar1
End Sub
 
@12arn, ben jij dezelfde als @wilma671? Zo nee, dan kan je beter een eigen vraag aanmaken anders ben je een inbreker:) Het quoten is overigens nergens voor nodig.
 
AD1957 zei:
Zo?
Code: 
Sub VenA()
  With Sheets("Factuur")
    c00 = .Range("B6").Value
    c01 = .Range("D4").Value
    ar = .Range("A11").CurrentRegion
  End With
  If UBound(ar) > 1 Then ReDim ar1(UBound(ar), 5) Else Exit Sub
    
        For j = 11 To UBound(ar) - 5
         If ar(j, 1) <> "" Then
            ar1(j - 11, 0) = c00
            ar1(j - 11, 1) = Format(ar(j, 1), "mm-dd-yyyy")
            ar1(j - 11, 2) = ar(j, 2)
            ar1(j - 11, 3) = ar(j, 3)
            ar1(j - 11, 4) = ar(j, 4)
            ar1(j - 11, 5) = c01
         End If
        Next j
    
  Sheets("Totale verkoop").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), 6) = ar1
End Sub
Klik om te vergroten...

Bedankt @ AD1957 en @VenA, dit is precies wat ik moest hebben!:thumb:
 
@VenA is degene die je echt moet bedanken.
Mij was het nooit gelukt om de code te maken. Echter door tijd te spenderen en de code leren te begrijpen is het
me gelukt om tot dit resultaat te komen.
Als je de berichten van VenA goed had gelezen was het jou ook gelukt.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan