Opgelost Data overnemen m.b.v. een VBA-script

[Jurgen2807]

Hallo,

Kan iemand mij helpen?

Ik zou graag de data vanaf rij 3 van tabblad BRON over willen nemen op tabblad DOEL.
1. De waarden die worden overgenomen dienen hard te zijn
2. De waarden die 0 zijn dienen niet overgenomen te worden (lege cel).

LET OP:
1. Data die naar tabblad DOEL wordt overgezet wordt in een tabel gezet met naam Tabel5
2. Data in kolommen J t/m AG op tabblad BRON zijn allemaal tot stand gekomen d.m.v. formules

Ik had onderstaande code gemaakt, maar die werkt niet. Ik krijg de foutmelding "De marco kan niet worden uitgevoerd. De marco is wellicht niet beschikbaar in dit werkblad of alle macro's zijn mogelijk uitgeschakeld".

Alle marco's zijn ingeschakeld in het vertrouwenscentrum. Daar ligt het niet aan. Ik heb macro's ook op andere tabbladen en die werken wel.

Kan iemand mij helpen?

De code die ik zelf had gemaakt:


Sub KopieerBRONnaarDOEL()

Dim bronSheet As Worksheet
Dim doelSheet As Worksheet
Dim rij As Long, kolom As Long
Dim laatsteRij As Long, laatsteKolom As Long
Dim waarde As Variant

' Verwijzing naar de werkbladen
Set bronSheet = ThisWorkbook.Sheets("BRON")
Set doelSheet = ThisWorkbook.Sheets("DOEL")

' Bepaal de laatste rij en kolom met data vanaf cel B3
laatsteRij = bronSheet.Cells(bronSheet.Rows.Count, 2).End(xlUp).Row
laatsteKolom = bronSheet.Cells(3, bronSheet.Columns.Count).End(xlToLeft).Column

' Loop door rijen vanaf 3 en kolommen vanaf kolom 2 (B)
For rij = 3 To laatsteRij
For kolom = 2 To laatsteKolom
waarde = bronSheet.Cells(rij, kolom).Value
If waarde = 0 Then
doelSheet.Cells(rij, kolom).ClearContents
Else
doelSheet.Cells(rij, kolom).Value = waarde
End If
Next kolom
Next rij

MsgBox "Data is succesvol gekopieerd van BRON naar DOEL", vbInformation

End Sub

 

[peter59]

Komt dit in de buurt?
Is dan wel niet met VBA maar met power query.

 

[Jurgen2807]

Dag Peter, dank. Zoals ik al eens heb aangegeven snap ik de ballen van Power Query op dit moment. Ik weet niet hoe je dit voor elkaar hebt gekregen en ik weet dus ook niet hoe ik dit in mijn originele bestand moet laden. Ik heb deadlines voor een aantal zaken en dus de tijd niet op dit moment om mij daarin te verdiepen. Dat ga ik zeker doen, maar op een rustiger moment voor mij.

Vandaar het liefst een VBA-script. Ik heb zitten oefenen, maar kom er niet uit.

 

[peter59]

Tja, je had al veel tijd kunnen besparen met Power Query en die tijd aan andere (leuke) dingen kunnen besteden.
In eerdere vragen gaf je ook al aan dat VBA niet je sterkste punt is.
Het is dus niet handig dat je nu afhankelijk bent van deadlines, en je steeds hier je oor te luister dient te leggen.
Hier een kleine uitleg van wat Power Query (al is het maar heel beknopt) voor je kan betekenen.

Om deze inhoud te bekijken, hebben we jouw toestemming nodig om cookies van derden te gebruiken.
Voor meer gedetailleerde informatie, zie onze cookiespagina.

Accepteer cookies van derden

 

[Jurgen2807]

Tja..... Ik heb volgens mij moeite gedaan om met een code op de proppen te komen. Ik wacht wel of iemand mij daarmee kan helpen. Zo niet, dan moet ik wat anders. In ieder geval dank.

 

[peter59]

Persoonlijk lijkt het me best lastig om onder druk van deadlines nog met zulke vragen te zitten. Hopelijk lukt het met VBA om op tijd een oplossing te vinden.

 

[Jurgen2807]

Beste Peter, laat ik het houden bij dank je wel. En ja dat is lastig, maar bij uitval neem ik zaken over. Ik hoop dat iemand wel naar mijn VBA code wil kijken.

 

[Jurgen2807]

Opgelost. Het is mij gelukt!

 

[AHulpje]

Het kan een tikkeltje sneller, 0,1 in plaats van 79 seconden:

Sub KopieerBRONnaarDOEL()
    Dim bronSheet As Worksheet
    Dim doelSheet As Worksheet
    Dim r As Long, k As Long
    Dim laatsteRij As Long, laatsteKolom As Long
    Dim a
   
    ' Verwijzing naar de werkbladen
    Set bronSheet = ThisWorkbook.Sheets("BRON")
    Set doelSheet = ThisWorkbook.Sheets("DOEL")
   
    ' Bepaal de laatste rij en kolom met data vanaf cel B3
    laatsteRij = bronSheet.Cells(bronSheet.Rows.Count, 2).End(xlUp).Row
    laatsteKolom = bronSheet.Cells(3, bronSheet.Columns.Count).End(xlToLeft).Column
   
    a = bronSheet.Cells(3, 2).Resize(laatsteRij - 2, laatsteKolom - 1)
    For r = 1 To UBound(a)
        For k = 1 To UBound(a, 2)
            If a(r, k) = 0 Then a(r, k) = ""
        Next
    Next
    doelSheet.Cells(3, 2).Resize(laatsteRij - 2, laatsteKolom - 1) = a
    MsgBox "Data is succesvol gekopieerd van BRON naar DOEL", vbInformation
End Sub

 

[HSV]

Netjes binnen beide tabellen.

Sub hsv()
Dim sv, i As Long, j As Long
sv = Sheets("Bron").ListObjects("totaledata_24").DataBodyRange
 For i = 1 To UBound(sv)
   For j = 9 To UBound(sv, 2)
     If sv(i, j) = 0 Then sv(i, j) = ""
   Next j
 Next i
  With Sheets("doel").ListObjects("tabel5")
   .DataBodyRange.Delete
   .ListRows.Add.Range.Resize(UBound(sv)) = sv
 End With
End Sub