VBA script aanpassen

jowey · 24 okt 2018

Hallo,

graag zou ik het volgende stukje code willen aanpassen.

Code:

Sub macro1()
Application.ScreenUpdating = False
Dim i As Long
i = Sheets("Facturen.test").Range("A" & Rows.Count).End(xlUp).Row

Sheets("Facturen.test").Cells(i + 1, 1) = Sheets("invulfactuur.test").Range("b17").Value
Sheets("Facturen.test").Cells(i + 1, 2) = Sheets("invulfactuur.test").Range("b16").Value
Sheets("Facturen.test").Cells(i + 1, 3) = Sheets("invulfactuur.test").Range("a3").Value
Sheets("Facturen.test").Cells(i + 1, 4) = Sheets("invulfactuur.test").Range("b33").Value
Sheets("Facturen.test").Cells(i + 1, 5) = Sheets("invulfactuur.test").Range("c33").Value
Sheets("Facturen.test").Cells(i + 1, 6) = Sheets("invulfactuur.test").Range("a33").Value
Sheets("Facturen.test").Cells(i + 1, 7) = Sheets("invulfactuur.test").Range("d33").Value
Sheets("Facturen.test").Cells(i + 1, 8) = Sheets("invulfactuur.test").Range("h33").Value
Sheets("Facturen.test").Cells(i + 1, 9) = Sheets("invulfactuur.test").Range("i33").Value

Application.ScreenUpdating = True
End Sub

Uitleg:
Met deze code kopieer ik gegevens naar een database. Echter is het mij alleen gelukt om 1 enkele rij te kopieren. Nu wil ik graag meerdere rijen tegelijk kunnen kopieren. Cell B16,B17 en A3 blijven daarbij altijd gelijk. Alle andere regels lopen vanaf rij 33 t/m 43 waarbij hij dus geen lege rijen daarvan mag kopieren.

Iemand die daarbij kan helpen?

Alvast bedankt

jowey · 25 okt 2018

oke al een beetje gevorderd.
De code doet nu wat ik wil alleen hij stopt niet bij een lege rij.
Er wordt tussen A33 en A43 data gevuld. De loop moet stoppen als hij de 1e lege waarde tegenkomt in kolom A
Hoe doe ik dat?

Code:

Sub macro1()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
i = Sheets("Facturen.test").Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 10


Sheets("Facturen.test").Cells(i + j, 1) = Sheets("invulfactuur.test").Range("b17").Value
Sheets("Facturen.test").Cells(i + j, 2) = Sheets("invulfactuur.test").Range("b16").Value
Sheets("Facturen.test").Cells(i + j, 3) = Sheets("invulfactuur.test").Range("a3").Value
Sheets("Facturen.test").Cells(i + j, 4) = Sheets("invulfactuur.test").Cells(32 + j, 2).Value
Sheets("Facturen.test").Cells(i + j, 5) = Sheets("invulfactuur.test").Cells(32 + j, 3).Value
Sheets("Facturen.test").Cells(i + j, 6) = Sheets("invulfactuur.test").Cells(32 + j, 1).Value
Sheets("Facturen.test").Cells(i + j, 7) = Sheets("invulfactuur.test").Cells(32 + j, 4).Value
Sheets("Facturen.test").Cells(i + j, 8) = Sheets("invulfactuur.test").Cells(32 + j, 8).Value
Sheets("Facturen.test").Cells(i + j, 9) = Sheets("invulfactuur.test").Cells(32 + j, 9).Value


Next


Application.ScreenUpdating = True
End Sub

snb · 25 okt 2018

Er ontbreekt een voorbeeldbestand.

Maak gebruik van arrays; zie http://www.snb-vba.eu/VBA_Arrays.html

jowey · 25 okt 2018

hierbij alsnog een voorbeeldbestand.Bekijk bijlage test.xlsm

VenA · 25 okt 2018

obv het voorbeeldbestand

Code:

Sub VenA()
  ar = Sheets("invulfactuur.test").UsedRange
  ReDim ar1(UBound(ar) - 31, 8)
  For j = 31 To UBound(ar)
    ar1(j - 31, 0) = ar(15, 2)
    ar1(j - 31, 1) = ar(14, 2)
    ar1(j - 31, 2) = ar(1, 2)
    ar1(j - 31, 3) = ar(j, 2)
    ar1(j - 31, 4) = ar(j, 3)
    ar1(j - 31, 5) = ar(j, 1)
    ar1(j - 31, 6) = ar(j, 4)
    ar1(j - 31, 7) = ar(j, 6)
    ar1(j - 31, 8) = ar(j, 7)
  Next j
  Sheets("facturen.test").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1) + 1, 9) = ar1
End Sub

snb · 25 okt 2018

Geef identieke kolomnamen in beide werkbladen aan kolommen met identieke gegevens.

Je kunt beter andersom werken: vanuit een tabel in facturen.test facturen aanmaken met behulp van een filter (autofilter of advancedfilter)

jowey · 25 okt 2018

@snb
De layout van de factuur is nu eenmaal zo. En ik wil alleen een database vullen met factuurlijnen.
Kan je een simpel opzet/voorbeeld geven van wat je bedoelt snb?

@VenA
Ik snap er niks van maar jouw code werkt perfect in het voorbeeldbestandje.
In originele bestand helaas niet. Ben even aan het proberen om het aan te passen om het alsnog werkend te krijgen.

jowey · 25 okt 2018

ik zit zelf in een loop denk ik

Code:

Sub VenA()
  ar = Sheets("invulfactuur.test").UsedRange
  ReDim ar1(UBound(ar) - 33, 8)
  For j = 33 To UBound(ar)
    ar1(j - 33, 0) = ar(17, 2)
    ar1(j - 33, 1) = ar(16, 2)
    ar1(j - 33, 2) = ar(3, 1)
    ar1(j - 33, 3) = ar(j, 2)
    ar1(j - 33, 4) = ar(j, 3)
    ar1(j - 33, 5) = ar(j, 1)
    ar1(j - 33, 6) = ar(j, 4)
    ar1(j - 33, 7) = ar(j, 6)
    ar1(j - 33, 8) = ar(j, 7)
  Next j
  Sheets("facturen.test").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1) + 1, 9) = ar1
End Sub

Dit stukje code doet nu precies wat mijn code al deed

VenA · 25 okt 2018

Een plaatje voegt niets toe net als een voorbeeldbestand dat qua lay-out niet identiek is aan het echte bestand. Wat is nu precies de bedoeling? Je wil toch een database opbouwen met een paar vaste gegevens (factuurnummer, datum en klantnaam) en een variabel aantal factuurregels?

Misschien beter zo

Code:

ar = Sheets("invulfactuur.test").Range("A3:G" & Sheets("invulfactuur.test").Cells(Rows.Count, 1).End(xlUp).Row)

jowey · 25 okt 2018

@VenA

Ik had het plaatje puur geplaatst om te laten zien waar het geplakt werd.
Het probleem is juist dat de layout van voorbeeld identiek is aan origineel.
daarom snap ik het ook niet.
Het enige verschil is dat er meerdere sheets zijn in het originele bestand.
Ik ga jouw laatste stukje code even proberen.

jowey · 27 okt 2018

oke 1 en ander verandert zodat het precies doet wat ik wil.
Echter nu loop ik tegen 1 laatste probleem aan.
Bij het plakken van de sheet Data factuurlijnen gaat het fout als ik die als een tabel instel.
VBA doet wat ik wil mits ik geen tabel instel. Nu wil ik graag toch een tabel instellen en dat mijn code hetzelfde doet

Hoe doe ik dat?

Code:

Sub macro1()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim NumberOfProductsInvulfactuur As Long
i = Sheets("Data factuurlijnen").Range("A" & Rows.Count).End(xlUp).Row
NumberOfProductsInvulfactuur = Sheets("invulfactuur").Range("A" & Rows.Count).End(xlUp).Row - 7

For j = 1 To NumberOfProductsInvulfactuur
    'Sheets("Data factuurlijnen").Cells(i + j, 1) = Sheets("invulfactuur").Range("b17").Value
    Sheets("Data factuurlijnen").Range("A" & (i + j)).Value = Sheets("invulfactuur").Range("b5").Value
    Sheets("Data factuurlijnen").Range("B" & (i + j)).Value = Sheets("invulfactuur").Range("b4").Value
    Sheets("Data factuurlijnen").Range("C" & (i + j)).Value = Sheets("invulfactuur").Range("B1").Value
    Sheets("Data factuurlijnen").Range("D" & (i + j)).Value = Sheets("invulfactuur").Range("B" & (7 + j)).Value
    Sheets("Data factuurlijnen").Range("E" & (i + j)).Value = Sheets("invulfactuur").Range("C" & (7 + j)).Value
    Sheets("Data factuurlijnen").Range("F" & (i + j)).Value = Sheets("invulfactuur").Range("A" & (7 + j)).Value
    Sheets("Data factuurlijnen").Range("G" & (i + j)).Value = Sheets("invulfactuur").Range("D" & (7 + j)).Value
    Sheets("Data factuurlijnen").Range("H" & (i + j)).Value = Sheets("invulfactuur").Range("F" & (7 + j)).Value
    Sheets("Data factuurlijnen").Range("I" & (i + j)).Value = Sheets("invulfactuur").Range("G" & (7 + j)).Value
    
Next j

Dim k As Integer

k = Sheets("Data facturen").Range("A" & Rows.Count).End(xlUp).Row

    Sheets("Data facturen").Range("A" & (k + 1)).Value = Sheets("invulfactuur").Range("B5").Value
    Sheets("Data facturen").Range("B" & (k + 1)).Value = Sheets("invulfactuur").Range("b1").Value
    Sheets("Data facturen").Range("C" & (k + 1)).Value = Sheets("invulfactuur").Range("b4").Value
    Sheets("Data facturen").Range("D" & (k + 1)).Value = Sheets("invulfactuur").Range("f18").Value
    Sheets("Data facturen").Range("E" & (k + 1)).Value = Sheets("invulfactuur").Range("f19").Value
    Sheets("Data facturen").Range("F" & (k + 1)).Value = Sheets("invulfactuur").Range("f20").Value
    Sheets("Data facturen").Range("G" & (k + 1)).Value = Sheets("invulfactuur").Range("f21").Value
    Sheets("Data facturen").Range("H" & (k + 1)).Value = Sheets("invulfactuur").Range("f22").Value

    Sheets("invulfactuur").Range("B1").Select
    Selection.ClearContents
    Sheets("invulfactuur").Range("b4:b5").Select
    Selection.ClearContents
    Sheets("invulfactuur").Range("a8:a17").Select
    Selection.ClearContents
    Sheets("invulfactuur").Range("b8:b17").Select
    Selection.ClearContents

    Sheets("instellingen").Select
    Range("B1").Select
    Selection.Copy
    Sheets("invulfactuur").Select
    Range("B5").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
  
     
    
Application.ScreenUpdating = True
End Sub

VBA script aanpassen

jowey

Gebruiker

jowey

Gebruiker

snb

Verenigingslid

jowey

Gebruiker

VenA

Inventaris

snb

Verenigingslid

jowey

Gebruiker

jowey

Gebruiker

VenA

Inventaris

jowey

Gebruiker

jowey

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy