Doorzoek kolom naar Partij ID kan meerdere keren voorkomen.

[roschatz]

Goedemorgen allemaal,

Ik zit met een kleine uitdaging.
Deze vba code zoekt in een kolom naar een Partij ID ( 6 cijfers )
Als in de kolom meerdere zelfde Partij ID zitten zal alleen de eerste
verwerkt worden.

Hoe krijg ik het voor elkaar dat na de eerste Partij ID gevonden is
en verwerkt dat vba verder kijkt naar nog meer Partij ID met de zelfde
nummer en die ook verwerken.

Het kan namelijk zijn dat de Partij ID allemaal het zelfde is met andere
Informatie denk aan prijzen of omschrijving enz

Ik hoop dat iemand mij kan helpen

Alvast bedankt

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

ean2 = TextBox1.Value * 1

ean1 = Mid(ean2, 8, 6) * 1

    'box als geen barcode is ingevuld
    If ean1 = "" Then

        geenscanning = InputBox(Prompt:="scanning is niet gebeurd?", Title:="actie wordt gestopt", Default:="tis gedaan")
        TextBox1.SetFocus
        Exit Sub

    End If



    'commander file openen
    'hier pad aanpassen
    
    Dim wbcom As Workbook
   Set wbcom = ActiveWorkbook
   
   Workbooks.Open Filename:= _
        "C:\Users\Rene_O\Desktop\Stickeren\Sticker informatie Nederland.xlsm"
    Set wbcom = ActiveWorkbook
    
    
    
    'ean zoeken in kolom Q
    'kolom Q mag geen blanco tussenlijnen bevatten vanaf rij 5
    
    i = 5
    hit1 = 0
    Do While Range("AO" & i).Value <> "" And hit1 = 0
        If Range("AO" & i).Value = ean1 Then
            'AN1 = Range("AI" & i).Value & ";" & Range("AC" & i).Value & ";" & Range("AM" & i).Value & ";" & Range("AA" & i).Value & ";" & Range("AB" & i).Value
            
            AI1 = "T" & Range("AI" & i).Value
            AC1 = Range("AC" & i).Value
            L1 = Range("L" & i).Value
            AM1 = Range("AM" & i).Value
            Z1 = Range("Z" & i).Value
            AA1 = Range("AA" & i).Value
            AQ1 = Range("AQ" & i).Value
            AF1 = Range("AF" & i).Value
            AG1 = Range("AG" & i).Value
            Q1 = Range("Q" & i).Value
            I1 = Range("I" & i).Value
            
            
            FF1 = Range("AN" & i).Value
            hit1 = 1
        End If
    
    i = i + 1
    Loop
    
    
    If hit1 = 0 Then
        
        geenmatch = InputBox(Prompt:="geen match gevonden?", Title:="actie wordt gestopt", Default:="tis gedaan")
    
    Else
        
        'bestand opslaan als TXT
        
        Set fs = CreateObject("Scripting.FileSystemObject")
        Dim bestand As String
        bestand = "C:\Users\Rene_O\Desktop\Stickeren\Commander\Txt bestanden\" & FF1 & ".txt"
        If fs.FileExists(bestand) Then
        fs.DeleteFile (bestand)
        End If

        'ergens een lege xlsx opslaan met de naam rene
        
        Workbooks.Open Filename:= _
            "C:\Users\Rene_O\Desktop\Stickeren\rene.xlsx"
        Range("F1").Value = AI1
        Range("G1").Value = AC1
        Range("H1").Value = AM1
        Range("I1").Value = AA1
        Range("J1").Value = AQ1
        Range("K1").Value = L1
        Range("L1").Value = Z1
        Range("M1").Value = AF1
        Range("N1").Value = AG1
        Range("O1").Value = Q1
        Range("p1").Value = I1
        
        Columns("A:E").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlToLeft
        ActiveWorkbook.Save
        ActiveWorkbook.SaveAs Filename:=bestand, FileFormat:= _
        xlText, CreateBackup:=False
        ActiveWorkbook.Close SaveChanges:=False
        
        wbcom.Save
        wbcom.Close
        
    End If




TextBox1.SetFocus
TextBox1.Value = ""


End Sub

 

[wampier]

Volgens mij hoef je alleen de "AND HIT1 = 0" weg te laten toch? (heb even geen excel maar dat stopt je huidige routine)

 

[roschatz]

Volgens mij hoef je alleen de "AND HIT1 = 0" weg te laten toch? (heb even geen excel maar dat stopt je huidige routine)

Het gaat erom dat de zoek opdracht wordt herhaald
omdat er een kans bestaat dat het Partij ID
meerdere malen kan voorkomen in de kolom.

Het is zo:

Zoeken naar het Partij ID in een kolom, na het vinden verschillende cellen verzamelen en wegschrijven naar een *.txt bestand daarna verder zoeken
naar het zelfde Partij ID.
Bij het vinden van het zelfde nummer de 2e weer verschillende cellen verzamelen en wegschrijven naar een *.txt bestand enz enz
tot het nummer niet meer gevonden wordt.

 

[wampier]

In principe heb je die code toch al? het enige wat je extra hoeft te doen is in je while loop de gevonden data tijdelijk opslaan en dan pas wegschrijven.

Wat je nu doet:

loop door cellen heen met while
indien gevonden: stop while
wegschrijven

Het enige wat je hoeft te veranderen is:

Loop door cellen heen met while
indien gevonden -> NIET stoppen, maar opslaan
verder gaan met doorlopen
alle gevonden instances opslaan

Je "misbruikt" hier nu cellen voor die je knipt en plakt en saved als tekst etc, maar dat hoeft niet. VBA ondersteund types en arrays en het direct aanmaken van tekstbestanden.

Je kunt alle gevonden waarden dus opslaan in een array en die array eventueel direct wegschrijven naar een tekstbestand.

Als alternatief kun je ook een nieuwe tab aanmaken in je bestand, daar alle gevonden oplossingen heen brengen en dan die tab opslaan als tekstbestand.

 

[roschatz]

Hallo Wampier,

Bedankt voor je snelle reactie.
Ik kan je helemaal volgen alleen het zodanig in elkaar zetten van een vba code is wat lastiger.

Indien je misschien een voorbeeld kan geven zal je me erg helpen.
Ieder geval bedankt voor je reactie

Mvg

René

 

[wampier]

even een kort voorbeeld met behoud van je naamgeving (je slaat ook FF op in je code maar schrijft die niet weg? heb ik weggelaten)

Type opslag
    AI1 As String
    AC1 As String
    L1 As String
    AM1 As String
    Z1 As String
    AA1 As String
    AQ1 As String
    AF1 As String
    AG1 As String
    Q1 As String
    I1 As String
End Type

Private Sub CommandButton1_Click()

    i = 5
    hit1 = 0
    Dim resultaten() As opslag
    ReDim resultaten(0)
    Do While Range("AO" & i).Value <> ""
        If Range("AO" & i).Value = ean1 Then
            'AN1 = Range("AI" & i).Value & ";" & Range("AC" & i).Value & ";" & Range("AM" & i).Value & ";" & Range("AA" & i).Value & ";" & Range("AB" & i).Value
            
            resultaten(UBound(resultaten)).AI1 = "T" & Range("AI" & i).Value
            resultaten(UBound(resultaten)).AC1 = Range("AC" & i).Value
            resultaten(UBound(resultaten)).L1 = Range("L" & i).Value
            resultaten(UBound(resultaten)).AM1 = Range("AM" & i).Value
            resultaten(UBound(resultaten)).Z1 = Range("Z" & i).Value
            resultaten(UBound(resultaten)).AA1 = Range("AA" & i).Value
            resultaten(UBound(resultaten)).AQ1 = Range("AQ" & i).Value
            resultaten(UBound(resultaten)).AF1 = Range("AF" & i).Value
            resultaten(UBound(resultaten)).AG1 = Range("AG" & i).Value
            resultaten(UBound(resultaten)).Q1 = Range("Q" & i).Value
            resultaten(UBound(resultaten)).I1 = Range("I" & i).Value
            ReDim Preserve resultaten(UBound(resultaten) + 1)
            
            ' FF1 = Range("AN" & i).Value wordt niet gebruikt ?
            hit1 = 1
        End If
    
    i = i + 1
    Loop
End Sub

Dit slaat alle gevonden resultaten weg in een array genaamd "resultaten"

die kun je zo weer doorlopen later:

for i = 0 to ubound(resultaten) - 1
      msgbox(resultaten(i).AI1)
next i

 

[roschatz]

FF1 = Range("AN" & i).Value wordt niet gebruikt ?

Bedankt weer voor de snelle reactie.
de AN is bedoelt om klant en layout aan te duiden.
die naam wordt dan ook weggeschreven als klantennaamlayout.txt

Ik ga er vanavond naar kijken.
Alvast bedankt voor de hulp.

mvg

René

 

[roschatz]

Wampier,

Ik wil je graag bedanken voor je hulp.
Ik heb er lang over nagedacht en kwam met de volgende oplossing.
Het partij ID wat gevonden moet worden na het vinden verwijderen,
eigenlijk veranderen naar een ander getal.

Werkt perfect.

Nogmaals bedankt

Gr.

René

FF1 = Range("AN" & i).Value wordt niet gebruikt ?

Bedankt weer voor de snelle reactie.
de AN is bedoelt om klant en layout aan te duiden.
die naam wordt dan ook weggeschreven als klantennaamlayout.txt

Ik ga er vanavond naar kijken.
Alvast bedankt voor de hulp.

mvg

René