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

Formules verticaal zoeken + als ?

Status
Niet open voor verdere reacties.
Plaats svp code tussen codetags. Lees het linkje in #13 nogmaals. Hoewel ik het nut er niet van inzie om al jouw data te gaan fragmenteren over verschillende tabjes is de code niet zo moeilijk.

Even opgesplitst in een Function en een Sub. De code kan effectiever door van het laatste blad uit te gaan maar daar mag je dan zelf over nadenken

Code: 
Function Bladnaam()
  c00 = Format(Date, "ddmmyyyy")
  For Each sh In Sheets
    If Left(sh.Name, 8) = c00 Then t = t + 1
  Next sh
  Bladnaam = IIf(t = 0, c00, c00 & Chr(64 + t))
End Function

Code: 
Sub VenA()
  Sheets("BasisXlt").Copy , Sheets(Sheets.Count)
  ActiveSheet.Name = Bladnaam
End Sub
 
De truc van de code heb ik intussentijd ontdekt :o:o:o wel handig, thx daarvoor

ik ben wel een leek hoor,
en nu kom je met een function af :cool::cool::cool::cool:

waar moet ik die plakken en/of hoe moet ik die dan laten uitvoeren
Als ik ze plak in vba (module), zie ik die niet terug tussen mijn macro's ?

Stel misschien absurde vragen, maar kan ff niet volgen ....

Sorry daarvoor alvast

Tom
 
@ Harry,

Ik heb vandaag geprobeerd om vanuit een bestaande sub, een nieuwe aan te maken, maar ik loop vast

Dit was de oorspronkelijke sub (van jou gekregen)(export data van inkoopboek naar stockbeheer)

Code: 
Sub TestExportStockbeheer2017()
Dim sh As Worksheet, c As Range, rng As Range, cl As Range
Application.ScreenUpdating = False
Set sh = ActiveSheet
With GetObject(ThisWorkbook.Path & "\StockBeheer2017.xlsm")
.Windows(1).Activate
  With .Sheets("stockbeheer")
Set rng = .Cells(Application.Max(14, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 2)
        If Len(sh.Name) = 9 Then
                sh.Range("A22:U" & Application.Max(22, sh.Cells(125, 4).End(xlUp).Row)).Copy
                Application.Goto .Cells(Application.Max(14, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
                .Cells(Application.Max(14, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).PasteSpecial -4122
                .Paste , True
                .Cells(Application.Max(14, .Cells(Rows.Count, 23).End(xlUp).Offset(1).Row), 23).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - Application.Max(14, .Cells(Rows.Count, 23).End(xlUp).Row)) = sh.Cells(4, 19).Value
                Application.CutCopyMode = 0
        End If
     For Each cl In .Range(.Cells(rng.Row, 2), .Cells(Rows.Count, 2).End(xlUp))
      If cl.Value = 0 Then
         If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)
      End If
     Next cl
    If Not c Is Nothing Then c.EntireRow.Delete
  End With
End With
End Sub

Nu wil ik van inkoopboek nog een export doen naar importlabels, maar enkel van kolom B
Ik had dit ineengeknutseld :rolleyes::rolleyes::rolleyes:

Code: 
Sub TestExportImportLabels()
Dim sh As Worksheet, c As Range, rng As Range, cl As Range
Application.ScreenUpdating = False
Set sh = ActiveSheet
With GetObject(ThisWorkbook.Path & "\ImportLabels.xls")
.Windows(1).Activate
  With .Sheets("test")
Set rng = .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 2)
        If Len(sh.Name) = 9 Then
                sh.Range("b22:b123" & Application.Max(22, sh.Cells(22, 2).End(xlUp).Row)).Copy
                Application.Goto .Cells(Application.Max(2, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
                .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).PasteSpecial -4122
                .Paste , True
    End If
        For Each cl In .Range(.Cells(rng.Row, 2), .Cells(Rows.Count, 2).End(xlUp))
      If cl.Value = 0 Then
         If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)
      End If
     
     Next cl
    If Not c Is Nothing Then c.EntireRow.Delete
       
  End With
End With
End Sub

Ik krijg geen foutmelding, maar raar maar waar, hij kopieert 3 x de data, en kan niet vinden waar dat zit, heb vanalles geprobeerd
Ik zal in bijlage het bestandje plaatsen, zo kan je zien wat er gebeurt.

Maar in tegenstelling tot wat we nodig hadden in stockbeheer (alle data op 1 pagina) moet hier in feite elk tabblad, in een andere werkmap "importlabels" op een apart tabblad (voorbeeld zal je aantonen wat ik bedoel)
Dit is omdat die file wordt opgeladen door een programma waarmee onze labels automatisch worden afgedrukt

Hierbij mijn bestandje

Bekijk bijlage ImportLabels.xls

ps: als je bestandje opent moet je naar 1ste tabblad test gaan, dan zie je wat de sub doet

Tom
 
Laatst bewerkt:
niet getest:

rood is verandering.
blauw moet je verwijderen.
Code: 
Set rng = .Cells(Application.Max(2, .Cells(Rows.Count, [COLOR=#ff0000]2[/COLOR]).End(xlUp).Offset(1).Row), 2)
        If Len(sh.Name) = 9 Then
                sh.Range("b22:b[COLOR=#0000ff]123[/COLOR]" & Application.Max(22, sh.Cells(22, 2).End(xlUp).Row)).Copy
                Application.Goto .Cells(Application.Max(2, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
                .Cells(Application.Max(2, .Cells(Rows.Count, [COLOR=#ff0000]2[/COLOR]).End(xlUp).Offset(1).Row), [COLOR=#ff0000]2[/COLOR]).PasteSpecial -4122
                .Paste , True
    End If
 
Harry,

Alles aangepast, maar krijg echter enkel de eerste rij gekopieerd (cel B22), alsook zet hij de data nu in kolom 2(B) in het blad test

Code: 
Sub TestExportImportLabels()
Dim sh As Worksheet, c As Range, rng As Range, cl As Range
Application.ScreenUpdating = False
Set sh = ActiveSheet
With GetObject(ThisWorkbook.Path & "\ImportLabels.xls")
.Windows(1).Activate
  With .Sheets("test")
Set rng = .Cells(Application.Max(2, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
        If Len(sh.Name) = 9 Then
                sh.Range("b22:b" & Application.Max(22, sh.Cells(22, 2).End(xlUp).Row)).Copy
                Application.Goto .Cells(Application.Max(2, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
                .Cells(Application.Max(2, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2).PasteSpecial -4122
                .Paste , True
    End If
        For Each cl In .Range(.Cells(rng.Row, 2), .Cells(Rows.Count, 2).End(xlUp))
      If cl.Value = 0 Then
         If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)
      End If
     
     Next cl
    If Not c Is Nothing Then c.EntireRow.Delete
       
  End With
End With
End Sub

harry,
Ook hebben we vanmorgen hier besproken, wat we nu juist willen, qua importlabels afdrukken (we hebben al geleerd op voorhand beslissingen te nemen :thumb:)

In tegenstelling tot het voorbeeld bestand, waar we op elk tabblad apart werken, gaan we werken met 1 sheet (dus de werkmap Importlabels, zal maar 1 tabblad hebben (momenteel genoemd "test")
Wat we graag zouden bekomen:
Uit werkmap InkoopBoek:
  • Elk tabblad wordt handmatig toegevoegd (dus geen macro die alle tabbladen ineens kopieert)
  • Copy van kolom B (Artikelnummer) (van rij 22 tot 123, als de rij is ingevuld)(dus lege rijen worden NIET meegenomen)
  • Copy van kolom H (Stock) (van rij 22 tot 123, als de rij is ingevuld)(dus lege rijen worden NIET meegenomen)
Naar werkmap ImportLabels tabblad "test"
  • Kolom B van Inkoopboek, komt in Kolom A "artikelnr:" van tabblad "test", vanaf rij 2 en steeds automatisch aanvullend op de eerstvolgende lege rij (In ImportLabels is rij 1 voorzien als kopveldteksten, hebben we nodig voor programma Labels Printen)
  • Kolom H van Inkoopboek, komt in Kolom F "Stock:" van tabblad "test"
  • Kolommen B - C - D - E zijn voorzien van werkende formules (moet dus niks voor gebeuren)

Na deze bewerking: (mag eventueel met andere macro opgestart worden)
Als de waarde in kolom C "aantal" > 1
  • nakijken of cel F "stock" > 0, wanneer de cel F=0 mag sub stoppen
  • als kolom C op bv: rij 5 bv:2 is (dan moet er berekening gemaakt worden 2-1 = 1 (dan moet er een extra rij automatisch ingevoegd worden juist onder de rij 5)(met identieke waardes van rij 5)
  • als kolom C op bv: rij 8 bv: 6 is (dan wordt de berekening 6 - 1 = 5 (dan worden er automatisch 5 rijen ingevoegd onder rij 8) (met identieke waardes van rij 8)
  • dus kolom C is een variabele, dat kan gaan van 1 tot .....
  • Opgelet: Kolom F "Stock" is gekopieerd als "koppeling" naar inkoopboek (dus als de waarde in inkoopboek van stock veranderd, wordt dat hier ook automatisch aangepast)

Na deze bewerking (indien mogelijk had ik graag dat bovenstaande en onderstaande in een macro opgenomen wordt)(zoniet 2 aparte :d:d)
Als de waarde in kolom F = 0
  • als kolom F "stock" = 0 (in werkmap "importlabels", mag de rij automatisch verwijderd worden

Ik heb mijn best gedaan om alles zo duidelijk mogelijk te omschrijven, zodoende er geen misverstanden zijn, en onnodig werk wordt geleverd.
want ik vermoed dat dit een niet evidente opgave is :(:(

bedankt alvast om dit te bekijken, maar ik vermoed dat we toch in fases zullen werken, vooraleer we tot het eindresultaat zullen komen

Tom
 
Ik heb je hele verhaal niet gelezen, je loopt veel te veel op de zaken vooruit.
Het een voor het ander.

Code: 
sh.Range("b22:b" & Application.Max(22, sh.Cells([COLOR=#ff0000]123[/COLOR], 2).End(xlUp).Row)).Copy

Of;
Code: 
sh.Range("b22:b" & Application.Max(22, sh.Cells([COLOR=#ff0000][/COLOR][COLOR=#ff0000]rows.count[/COLOR], 2).End(xlUp).Row)).Copy
 
harry,

met de eerste aanpassing werkt het prima !
met de 2de krijg ik een foutmelding paste true

dus we gaan voor de eerste aanpassing, maar hij plakt in kolom B, en moet kolom A zijn, hij begint wel op rij 2 (dus dat is juist !), en ik vind niet direct waar ik de kolom kan aanpassen in de sub :o:o:o

ps: ik had het ganse verhaal geschreven, als ondersteuning, zodoende we geen "verloren" werk uitvoeren !

Tom
 
Code: 
Application.Goto .Cells(Application.Max(2, .Cells(Rows.Count, [SIZE=4][COLOR=#ff0000]1[/COLOR][/SIZE]).End(xlUp).Offset(1).Row),[COLOR="#FF0000"] 1[/COLOR])
                .Cells(Application.Max(2, .Cells(Rows.Count, [SIZE=4][COLOR=#ff0000]1[/COLOR][/SIZE]).End(xlUp).Offset(1).Row),[COLOR="#FF0000"]1[/COLOR]).PasteSpecial -4122
 
Werkt perfect !

Volgende stap:
Wat we graag zouden bekomen:
Uit werkmap InkoopBoek:
Elk tabblad wordt handmatig toegevoegd (dus geen macro die alle tabbladen ineens kopieert) (werkt)
Copy van kolom B (Artikelnummer) (van rij 22 tot 123, als de rij is ingevuld)(dus lege rijen worden NIET meegenomen) (werkt)

Copy van kolom H (Stock) (van rij 22 tot 123, als de rij is ingevuld)(dus lege rijen worden NIET meegenomen)

dus ik moet ergens H22:h toevoegen om dit te bereiken, heb hier geprobeerd maar krijg het niet voor elkaar, steeds foutmeldingen

brrr, ik leer elke dag stapje voor stapje, maar blijf een leek in deze materie :o

Tom
 
Plaats het bestand eens, want dit gaat maar door.
 
Importlabels is definitief bestand, inkoopboektest (is een gedeelte anders te groot om mee te voegen)

Bekijk sheet "test", daar moet dus in kolom a, kolom b komen van inkoopboek (dat werkt al)
Nu wil ik ook nog de kolom stock naar kolom H brengen in "test"

Wat ik wel heb opgemerkt is dat de sub een foutvermelding geeft bij kopie van kolom B naar kolom A (geeft foutmelding in sub) dit gebeurt enkel als de formules aanwezig zijn in tabblad test ....
Code: 
For Each cl In .Range(.Cells(rng.Row, 2), .Cells(Rows.Count, 2).End(xlUp))
      If cl.Value = 0 Then
         If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)

Als nu de beide koloms goed worden gekopieerd, dan komt in feite maar de moeilijkheid vermoed ik .....

Zoals reeds hierboven beschreven

Na deze bewerking: (mag eventueel met andere macro opgestart worden)
Als de waarde in kolom C "aantal" > 1
nakijken of cel F "stock" > 0, wanneer de cel F=0 mag sub stoppen
als kolom C op bv: rij 5 bv:2 is (dan moet er berekening gemaakt worden 2-1 = 1 (dan moet er een extra rij automatisch ingevoegd worden juist onder de rij 5)(met identieke waardes van rij 5)
als kolom C op bv: rij 8 bv: 6 is (dan wordt de berekening 6 - 1 = 5 (dan worden er automatisch 5 rijen ingevoegd onder rij 8) (met identieke waardes van rij 8)
dus kolom C is een variabele, dat kan gaan van 1 tot .....
Opgelet: Kolom F "Stock" is gekopieerd als "koppeling" naar inkoopboek (dus als de waarde in inkoopboek van stock veranderd, wordt dat hier ook automatisch aangepast)


Na deze bewerking (indien mogelijk had ik graag dat bovenstaande en onderstaande in een macro opgenomen wordt)(zoniet 2 aparte )
Als de waarde in kolom F = 0
als kolom F "stock" = 0 (in werkmap "importlabels", mag de rij automatisch verwijderd worden

Als er vragen zijn, hoor ik het graag.

Ps: Reden waarom rijen moeten gekopieerd worden, als aantal groter is dan 1, als we bv 3 jurken hebben met maat M, staat deze rij maar 1 in de sheet om de labels te drukken, en mankeren we labels, daarom moeten er 2 extra rijen aangemaakt worden.

Tom

Bekijk bijlage ImportLabels.xlsBekijk bijlage InkoopBoek2017Test.xlsm
 
Laatst bewerkt:
Wanneer moeten er extra rijen worden aangemaakt.

Als C2=3 en F2=1, dan 2 extra rijen?
Als C5=10 en F5=2, dan 8 extra rijen?
 
Extra rijen enkel te bepalen door kolom F (c heeft hier geen betrekking, ik probeer het uit te leggen, C= het laatste karakter van kolom A, dit is voor ons te weten hoeveel stukken er van dat artikel zijn aangekocht)
wat kan er nu gebeuren, stel je heb in kolom c "5" staan, hetgeen wil zeggen dat er 5 stuks zijn aangekocht, maar in werkelijkheid gebeurt het dat er reeds artikelen worden verkocht, vooraleer ze gelabeld worden ....
Daarom hebben we de kolom stock meegenomen, staat daar bv 4, dan moeten er 3 extra rijen ingevoegd worden, staat daar bv 2 dan moet er 1 rij ingevoegd worden, staat er bv 6 dan 5 rijen inboegen
Staat er 1 dan moet er niks gebeuren, staat er 0 dan mag rij verwijderd worden.

Daarom ook dat kolom F een plakken koppeling moet zijn, omdat stock dagelijks veranderd, zo kunnen er nooit teveel labels afgedrukt worden (het gebeurt dat labels opnieuw moeten afgedrukt worden, door bv beschadiging van het label, enz)

Is het duidelijk ?

Tom
 
Dat gaat niet meer met verwijzingen lukken.
 
Oeps, das minder leuk nieuws dan
Dus we moeten een verwijzing maken tussen kolom C en F ? (en we kunnen daar geen formule op gebruiken?

Hoe kunnen we dan op basis van een celwaarde, een rij toevoegen ?
 
Gewoon als waarden plakken.
 
Harry,

Geen probleem, ik zal dan handmatig elke maand de data opnieuw exporteren

daarover een vraagske:
Ik had nu graag dat ik tabblad per tabblad van werkmap "inkoopboek" kon exporteren naar importlabels
maar met nu de nieuwe werkwijze, kan het volgende ? dat alle tabbladen ineens exporteren, maar op voorwaarde dat er geen dubbele identieke rijen aanwezig zijn ?
dit kan op artikelnummer, dat zijn unieke waarden !

is maar een idee van mij he

tom
 
Code: 
Sub TestExportImportLabels() 
Dim sh As Worksheet, c As Range, rng As Range, cl As Range
Application.ScreenUpdating = False
Set sh = ActiveSheet
With GetObject(ThisWorkbook.Path & "\ImportLabels.xlsx")
.Windows(1).Activate
  With .Sheets("test")
Set rng = .Cells(Application.Max(2, .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row), 6)
        If Len(sh.Name) = 9 Then
 sn = sh.Range("B22:H" & Application.Max(22, sh.Cells(123, 2).End(xlUp).Row))


      For j = 2 To UBound(sn)
       c00 = c00 & Replace(String(sn(j, 5), " "), " ", " " & j)
      Next
   st = Application.Transpose(Split(Trim(c00)))
 .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).Resize(UBound(st)) = Application.Index(sn, st, 1)
 .Cells(Application.Max(2, .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row), 6).Resize(UBound(st)) = Application.Index(sn, st, 7)
    End If
        For Each cl In .Range(.Cells(rng.Row, 6), .Cells(Rows.Count, 6).End(xlUp))
      If cl.Value = 0 Then
         If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)
      End If
    Next cl
  If Not c Is Nothing Then c.EntireRow.Delete
 End With
End With
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan