Adres labels maken door vooraf te checken of het moet

Status
Niet open voor verdere reacties.
H

harmnaberman

Gebruiker
Lid geworden
31 jan 2019
Berichten
44
Hallo,

Ik ben opzoek naar VBA code voor het maken van adres label.
Adres gegevens moet uit een excel document gekopieerd worden.
(LET OP: Niet alle adressen moet gekopieerd worden.)

Welke adressen moet dan wel gekopieerd worden?
In het excel document 'Sheet 1' in kolom B staan ''referentie' nummers.
Op 'Sheet 2' kolom A staan alle mogelijk referentie nummers waarvan een adres label moet worden aangemaakt. Staat de referentie nummer niet in kolom A op 'Sheet 2' dan moet er geen adres label worden aangemaakt of moet het worden overgeslagen.

Hoe moet de adres labels er dan uitzien?
Op 'Sheet 3' heb ik handmatig een aantal labels gemaakt.

Zie de bijlage voor meer info en wat ik al heb gedaan.

Als er nog onduidelijkheden zijn dan hoor ik dat ook graag.

Ik hoop dat iemand mij kan helpen.
 
Laatst bewerkt door een moderator:
Jij lijkt je beter thuis te voelen bij Excel formules dan bij VBA.

Gebruik in sheet 3: =IF(ISNUMBER(MATCH('Sheet 1'!B3;'Sheet 2'!$A$1:$A$16;0));"";'Sheet 1'!F3)

Dan gebruik je autofilter om lege regells te verbergen en je bent klaar.
 
Bedankt voor de snelle reactie.

Ik heb het even geprobeerd, het werkt wel, maar het moet nog sneller kunnen met een druk op de knop neem ik aan?

Of is mij vraag te complex?
 
Laatst bewerkt:
Adreslabels gaat over het algemeen makkelijker vanuit Word. (geen gehannes me positionering) Kolom B lijkt mij overbodig omdat je ook zaken aan elkaar kan plakken. Postcode en plaats onder elkaar is ook niet bepaald logisch.

Code: 
Sub VenA()
  With Sheets("Sheet 2")
    Sheets("Sheet 1").Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Cells(1).CurrentRegion, .Cells(1, 4)
    ar = .Cells(1, 4).CurrentRegion
    .Cells(1, 4).CurrentRegion.Clear
  End With
  ReDim ar1(UBound(ar) * 4)
    For j = 2 To UBound(ar)
      ar1(t) = ar(j, 6)
      ar1(t + 1) = ar(j, 4) & " " & ar(j, 5)
      ar1(t + 2) = ar(j, 7) & " " & ar(j, 8)
      ar1(t + 3) = ar(j, 9) & "  " & ar(j, 10)
      t = t + 4
    Next j
    With Sheets("Sheet 3")
      .UsedRange.Clear
      .Cells(1).Resize(t, 1) = Application.Transpose(ar1)
      For j = 1 To t Step 4
        Cells(j, 1).Resize(4, 2).BorderAround , 4
      Next j
    End With
End Sub
 
Laatst bewerkt:
Of:
Code: 
Sub hsv()
 With Sheets("Sheet 2")
    Sheets("Sheet 1").Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Cells(1).CurrentRegion, .Cells(1, 4)
    ar = .Cells(1, 4).CurrentRegion
    .Cells(1, 4).CurrentRegion.Clear
  End With
  ReDim ar1(UBound(ar))
    For j = 2 To UBound(ar)
      ar1(t) = ar(j, 6) & vbLf & ar(j, 4) & " " & ar(j, 5) & vbLf & ar(j, 7) & " " & ar(j, 8) & vbLf & ar(j, 9) & "  " & ar(j, 10)
      t = t + 1
    Next j
    With Sheets("Sheet 3")
      .UsedRange.Clear
      .Cells(1).Resize(t, 1) = Application.Transpose(ar1)
      For j = 1 To t
        .Cells(j, 1).WrapText = True
        .Cells(j, 1).Resize(, 2).BorderAround , 4
      Next j
    End With
End Sub
 
Hallo Vena, HSV,

Bedankt voor het mee denken en de snelle reactie.

Ik moet er nog even doorheen. Ik krijg foutmelding 1004 (het ophaalbereik heeft geen of een ongeldige bestandsnaam).
Ik gebruik een Nederlandse versie van Excel, kan het zijn dat ik de code om moet zetten naar Nederlandse termen?

@Vena
Adreslabel in Word maken heb ik al geprobeerd, maar omdat er een zoek opdracht aan vooraf gaat en ik een eigen opmaak heb als label die mee geprint moet worden is het mij niet gelukt om het in Word te doen. Daar heb ik wel naar gekeken.
 
Zet in sheet2!A1: referentie
 
Hallo HSV,

Geweldig, het werkt.
Ik ben al een aantal avonden bezig geweest, maar helaas niet gelukt.

De code begrijp ik niet helemaal, ik snap ook niet hoe jullie dit allemaal zo snel voor elkaar kan krijgen.

Als ik het lezen en schrijven van de code wil leren, kan ik dan het beste een of meerdere cursussen volgens (welke cursussen dan?)
 
Beginnerscursus VBA.

Of zelfstudie door wat berichten te volgen en uit te pluizen met de Help in de VB-editor (de Help van VBA waar je de codes plaatst).
 
Bedankt iedereen voor jullie hulp.

Het zoeken en kopiëren werkt.

Ik heb nog wel een aantal andere kleine probleempjes, mag ik dat hier op deze vraag ook stellen of moet ik dan een nieuwe bericht plaatsen?
 
Als de vervolgvragen aansluiten op dit probleem, zou ik ze er bij zetten. Is het een ander probleem, dan een nieuwe vraag maken.
 
Als aangegeven, het eerste deel van de macro werkt prima.

Ik ben zelf nog even bezig geweest om een stukje macro op te nemen om de tekst in de cellen (Sheet 3) groter te maken, kolom breder te maken, rijen hoger te maken etc.

Wat ik nog graag zal willen:
1) Adres gegevens in de cellen kleiner maken dat alle tekst leesbaar is in de kollom. In de volgende cellen van kollom A (A20, A26 en A27) valt nu een deel van de adres gegevens weg. ) Waarom wil ik de adres gegevens kleiner maken en niet de cellen groter maken: omdat ik deze adres gegevens op een formaat 99014 adres label moet kunnen printen.

2) De adres labels op Sheet 3 wil ik met een druk op de knop als PDF kunnen opslaan (dan graag alleen de cellen opslaan die gevuld zijn met een adres). Kan dat ook met behulp van een eenvoudige macro? Daar komt als uitdaging bij dat ik deze handeling 2 of drie keer per dag en vijf dagen per week moet doen. Het PDF bestand moet dus elke keer een andere naar krijgen (bijvoorbeeld bestand 1 heeft naam: “28-07-2020_1”; bestand 2 heeft naam: “28-07-2020_2”; bestand 3 heeft naam: “28-07-2020_3”, de volgende dag bestand 1 heeft naam: “29-07-2020_1”; bestand 2 heeft naam: “29-07-2020_2” etc.

3) Met een macro twee verschillende printers aansturen. Kan ik sheet 1 op een A4 printer uitprinten en Sheet 3 met een Dymo label printer?

Zie de bijlage voor een update van mijn excel bestand
 
Laatst bewerkt door een moderator:
1 en 2.
Code: 
Sub TEST1()
 With Sheets("Sheet 2")
    Sheets("Sheet 1").Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Cells(1).CurrentRegion, .Cells(1, 4)
    ar = .Cells(1, 4).CurrentRegion
    .Cells(1, 4).CurrentRegion.Clear
  End With
  ReDim ar1(UBound(ar))
    For j = 2 To UBound(ar)
      ar1(t) = ar(j, 6) & vbLf & ar(j, 4) & " " & ar(j, 5) & vbLf & ar(j, 7) & " " & ar(j, 8) & vbLf & ar(j, 9) & "  " & ar(j, 10)
      t = t + 1
    Next j
    With Sheets("Sheet 3")
      .UsedRange.Clear
      .Cells(1).Resize(t, 1) = Application.Transpose(ar1)
      For j = 1 To t
[COLOR=#ff0000]        sv = .Cells(j, 1)[/COLOR]
[COLOR=#ff0000]        .Cells(j, 1).Font.Size = 20[/COLOR]
[COLOR=#ff0000]        .Cells(j, 1).Characters(Application.Find(ar(j + 1, 7), sv), Len(sv)).Font.Size = 15[/COLOR]
        .Cells(j, 1).WrapText = True
        '.Cells(j, 1).Resize(, 2).BorderAround , 4
      Next j
    End With
End Sub
Code: 
Sub hsv()
 Sheets("sheet 3").Cells(1).CurrentRegion.ExportAsFixedFormat 0, "D:\users\harm\desktop\" & Format(Now, "dd-mm-yyyy hh_mm_ss")
End Sub

3. Neem een macro op met de recorder, daar komen dan de juiste gegevens uit die iemand anders niet kan verzinnen.
 
Laatst bewerkt:
Hallo Harry,

Nogmaals bedankt.

Ik heb het ook al toegevoegd aan mijn huidige Macro code.

Vraag 1, ik zag dat je van alle cellen de laatste twee regels zin tekst kleiner maakt.
Maar stel ik heb een straatnaam die nog langer is dan moet de tekst nog kleiner (met dit voorbeeld zal ik het altijd moeten checken.)
Kan het niet geautomatiseerd worden door te laten kijken als een tekstregels bijvoorbeeld te lang word de tekst dan kleiner te maken? (ik ben niet zo handig met VBA dat ik weet of het mogelijk is.)

Vraag 2 is gelukt. Bedankt. Ik sla het op naar een NAS maar dat is prima gelukt.

Vraag 3, om een print actie te recorden werkt op een of ander manier niet. Ik heb het al geprobeerd. De laatst geselecteerde printer lijkt actief te blijven. Ik heb beide print acties gerecord, maar als ik dan de eerste recording weer afspeelt dan krijg ik een foutmelding. Volgens mij fout 438 (weet ik niet helemaal meer zeker, zal het moeten nakijken).
 
Dan moet je met een niet proportioneel lettertype werken(in de code aangepast).

Speel wat met het getal 175 in de code en de lettergrootte.

Code: 
Sub hsv()
 With Sheets("Sheet 2")
    Sheets("Sheet 1").Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Cells(1).CurrentRegion, .Cells(1, 4)
    ar = .Cells(1, 4).CurrentRegion
    .Cells(1, 4).CurrentRegion.Clear
  End With
  ReDim ar1(UBound(ar))
    For j = 2 To UBound(ar)
      ar1(t) = ar(j, 6) & vbLf & ar(j, 4) & " " & ar(j, 5) & vbLf & ar(j, 7) & " " & ar(j, 8) & vbLf & ar(j, 9) & "  " & ar(j, 10)
      t = t + 1
    Next j
    With Sheets("Sheet 3")
      .UsedRange.Clear
      .Cells(1).Resize(t, 1) = Application.Transpose(ar1)
      For j = 1 To t
        sv = .Cells(j, 1)
        .Cells(j, 1).Font.Name = "lucida sansi unicode"
        .Cells(j, 1).Font.Size = 20
       tl = IIf(Len(ar(j + 1, 9)) + Len(ar(j + 1, 10)) > Len(ar(j + 1, 7)), Len(ar(j + 1, 9)) + Len(ar(j + 1, 10)) + 1, Len(ar(j + 1, 7)))
        .Cells(j, 1).Characters(Application.Find(ar(j + 1, 7), sv), Len(sv)).Font.Size = 175 / tl
        .Cells(j, 1).WrapText = True
        '.Cells(j, 1).Resize(, 2).BorderAround , 4
      Next j
    End With
End Sub
 
@Harry, Bedankt voor de update van de code.
Ik heb het geprobeerd, maar dat leverde niet op wat ik graag wil. Als de straatnaam lang is dan word het te klein op de adreslabel. Ik heb het getal 175 vervangen door hogere en lagere getallen om te zien wat er gebeurt.

Ondertussen heb ik ook de code van VENA geprobeerd.
Met deze code word het bedrijfsnaam in een rij gekopieerd op sheet 3, voornaam en achternaam in de volgende rij, straatnaam en huisnummer in de volgende rij en postcode en plaat in de volgende rij.

Voor mezelf heb ik al bedacht dat ik eenvoudig een macro kan opnemen door de kollommen breder te maken (twee keer te klikken op verticale lijn van een kolom.) Vervolgens de functie passend te gebruiken tijdens het printen dan staat alle tekst op de adreslabel.

Nu zit ik nog wel met hel volgende.
Ik moet dus 4 rijen op een of andere manier kunnen groeperen, omdat 4 rijen een adres label is, maar hoe doe ik dat met VBA code?
Dat ook omdat het zo geprint moet kunnen worden.

Is het ook mogelijk om alleen adreslabels met daadwerkelijk een adres er in actief te stellen voor het printen of als ik het wil opslaan als PDF? Reden waarom ik dit vraag is omdat ik bijvoorbeeld maar 10 gevulde adres labels heb en er zijn 100 adres labels actief, mijn printer 100 labels laat printen waarvan 90 dan niks op staat.

Ik heb weer een Excel bestand toegevoegd met daarin de code van VENA en het op maat maken van de adreslabel.

Ik hoop dat iemand mij kan helpen.
 
Laatst bewerkt door een moderator:
De kolom breder maken kan in de code.
Code: 
Columns.autofit

Maar hoe zit het dan met...
formaat 99014
 
Zit er geen software bij de Dymo label printer die het voor je afhandelt. Zelf gebruik ik labelmatrix pro en heb nog nooit problemen ondervonden met de lengte van een veldnaam. Het formaat van de labels is iets kleiner dan de door jouw gebruikte. (100 x 50 mm).
Je zou het geavanceerde filter eens kunnen bestuderen. Om de lege straten niet mee te nemen
Code: 
 With Sheets("Sheet 2")
    .Cells(1, 2).Resize(2) = Application.Transpose(Array("adres_verz_straat", "<>"))
 
HSV zei:
1 en 2.
Code: 
Sub TEST1()
 With Sheets("Sheet 2")
    Sheets("Sheet 1").Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Cells(1).CurrentRegion, .Cells(1, 4)
    ar = .Cells(1, 4).CurrentRegion
    .Cells(1, 4).CurrentRegion.Clear
  End With
  ReDim ar1(UBound(ar))
    For j = 2 To UBound(ar)
      ar1(t) = ar(j, 6) & vbLf & ar(j, 4) & " " & ar(j, 5) & vbLf & ar(j, 7) & " " & ar(j, 8) & vbLf & ar(j, 9) & "  " & ar(j, 10)
      t = t + 1
    Next j
    With Sheets("Sheet 3")
      .UsedRange.Clear
      .Cells(1).Resize(t, 1) = Application.Transpose(ar1)
      For j = 1 To t
[COLOR=#ff0000]        sv = .Cells(j, 1)[/COLOR]
[COLOR=#ff0000]        .Cells(j, 1).Font.Size = 20[/COLOR]
[COLOR=#ff0000]        .Cells(j, 1).Characters(Application.Find(ar(j + 1, 7), sv), Len(sv)).Font.Size = 15[/COLOR]
        .Cells(j, 1).WrapText = True
        '.Cells(j, 1).Resize(, 2).BorderAround , 4
      Next j
    End With
End Sub
Code: 
Sub hsv()
 Sheets("sheet 3").Cells(1).CurrentRegion.ExportAsFixedFormat 0, "D:\users\harm\desktop\" & Format(Now, "dd-mm-yyyy hh_mm_ss")
End Sub

3. Neem een macro op met de recorder, daar komen dan de juiste gegevens uit die iemand anders niet kan verzinnen.
Klik om te vergroten...

Met de code kan ik de PDF nu opslaan naar een aangegeven locatie, maar is het ook mogelijk om het opgeslagen bestand nadat het is opgeslagen gelijk te openen?

Waarom wil ik het opgeslagen bestand openen?: dan kan ik er snel doorheen kijken of alles klopt.
 
Zet aan het einde 6 komma's en dan -1
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan