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

regels verplaatsen naar aparte werkmap en per werkmap opslaan

  • Onderwerp starter Onderwerp starter HWV
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
HWV

HWV

Terugkerende gebruiker
Lid geworden
19 feb 2009
Berichten
1.213
Beste,

Ik ben al aardig op weg maar krijg het niet werkend.
Ik moet vanuit een bestand elke nacht een bewerking uitvoeren.
Per klantnr. kolom A, moeten alle regels met die code verplaats worden naar een aparte tabblad met de klantnummer als naam, dan doe ik daar een opmaak over en dan moet het per map opgeslagen worden.

Hij kopieer nu wel de regels naar een aparte tabblad maar doet dit per regel een aparte tabblad en alleen de eerste geef hij de klantnr.

Code: 
Sub lijsten()
On Error GoTo Err_Knop1_Click

Workbooks.Open Filename:="\\ZNPSV01\Data\automatisering\Klantlijstenassortiment\lijst-artikelen-alle klanten.xls"

Windows("lijst-artikelen-alle klanten.xls").Activate
Sheets("Data1").Select

Workbooks("lijst-artikelen-alle klanten.xls").Sheets("Data1").Range("A1:Z25000").Copy Workbooks("VS-Lijst alle klanten bewerken automatisch.xlsm").Sheets("Data1").Range("A1:Z25000")

Windows("lijst-artikelen-alle klanten.xls").Activate
Sheets("Data1").Select

Dim c As Range
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim sh As Object
    
    On Error Resume Next
    
    Set ws1 = ThisWorkbook.Worksheets("Data1")
    
    For Each c In ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp)) 'was A2
        
        If WksExists(c.Text) Then
        
            Set ws = ThisWorkbook.Worksheets(c.Text)
            
        Else
        
            Set ws = ThisWorkbook.Worksheets.Add
            ws.Name = c.Text
        
        End If
        
        c.Resize(, 25).Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
    Next

ws1.Select

    For Each sh In ThisWorkbook.Sheets
        If sh.Index > "" Then
                Sheets(sh.Name).Select
                
           'Formule 'aanroepen formule opmaak formulier

        End If
    
    Next sh

    For Each ws In ThisWorkbook.Worksheets
           
        Sheets(ws.Name).Select
        Sheets(ws.Name).Copy
        ActiveWorkbook.SaveAs Filename:= _
        "\\ZNPSV01\Data\automatisering\Klantlijstenassortiment\" & ws.Name & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
        ThisWorkbook.Activate
    Next

Workbooks("lijst-artikelen-alle klanten.xls").Close SaveChanges:=False

Exit_Knop1_Click:
Exit Sub
Err_Knop1_Click:
MsgBox Err.Description
Resume Exit_Knop1_Click
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Bekijk bijlage VS-Lijst alle klanten bewerken automatisch-1.xlsm
en
Bekijk bijlage lijst-artikelen-alle klanten.xls

Ik zie niet waar het fout gaat!

HWV
 
Laatst bewerkt:
Rij voor rij kopiëren is niet een echt handige methode. Gebruik hiervoor het autofilter of het geavanceerde filter. Maak ook zo min mogelijk gebruik van Select en Activate. Wat het eind resultaat moet worden kan ik er niet helemaal uithalen. Onderstaande code maakt in het bestand 'lijst-artikelen-alle klanten.xls' nieuwe tabjes aan per debiteur.

Code: 
Sub VenA()
Application.ScreenUpdating = False
c00 = "D:\Temp\"
Workbooks.Open (c00 & "lijst-artikelen-alle klanten.xls")
With Sheets("Data1")
    ar = Sheets("Data1").Cells(1).CurrentRegion
    Sheets("Data1").Range("A1:Z25000").Copy Workbooks("VS-Lijst alle klanten bewerken automatisch.xlsb").Sheets("Data1").Range("A1:Z25000")
    For j = 2 To UBound(ar)
        If InStr(1, c01, ar(j, 1)) = 0 Then c01 = c01 & "|" & ar(j, 1)
    Next j
    For jj = 1 To UBound(Split(c01, "|"))
        If IsError(Evaluate(Split(c01, "|")(jj) & "!A1")) Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Split(c01, "|")(jj)
        End If
        With .Cells(1).CurrentRegion
            .AutoFilter 1, Split(c01, "|")(jj)
            .Copy Sheets(Split(c01, "|")(jj)).[A1]
            .AutoFilter
        End With
    Next jj
End With
End Sub

Het nut van
Code: 
Sheets("Data1").Range("A1:Z25000").Copy Workbooks("VS-Lijst alle klanten bewerken automatisch.xlsb").Sheets("Data1").Range("A1:Z25000")
ontgaat mij.
 
gevonden

hoe moeilijk kan het zijn, gevonden het zat in het rode stukje

Code: 
 [COLOR="#FF0000"]Sheets("Data1").Select[/COLOR]
        c.Resize(, 25).Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)

Nu ga ik nog even stoeien hoe ik ook de kophoofd ( regel 1) meeneem naar alle bladen

HWV
 
net elkaar gekruist

VenA,

Bedankt voor je antwoord, mij topic en die van jou hebben elkaar net gekruist.
Het is idd gelukt ik ben er uit en zeker geholpen, bedankt:thumb:

HWV
 
Volgens mij heb ik geen topic open staan. Dus zal je wel wat anders bedoelen. En verder lees #2 nogmaals.
 
Jij had gereageerd en ik ook, dat bedoelde ik. Sorry voor de onduidelijkheid.

Jij vraag die je stelt, is wat voor nut het heeft. Is inderdaad achteraf ook overbodig.
Met jou code en je uitleg zal ik proberen de select en acrobate te vermijden.

Waar ik nog wel mee aan het stoeien ben is het opslaan per tabblad, met de naam van het tabblad.

Nogmaals bedankt, en als je hier ook iets op weet hou ik mij aanbevolen

Hwv
 
nog een aanvullende vraag

Beste,

Ik werk nu met de code die is aangeboden door VenA:
Code: 
c00 = "Q:\Batch\Lijst alle klanten\"
Workbooks.Open (c00 & "lijst-artikelen-alle klanten.xls")
With Sheets("Data1")
    ar = Sheets("Data1").Cells(1).CurrentRegion
    Sheets("Data1").Range("A1:Z25000").Copy Workbooks("VS-Lijst alle klanten bewerken automatisch.xlsm").Sheets("Data1").Range("A1:Z25000")
    For j = 2 To UBound(ar)
        If InStr(1, c01, ar(j, 1)) = 0 Then c01 = c01 & "|" & ar(j, 1)
    Next j
    For jj = 1 To UBound(Split(c01, "|"))
        If IsError(Evaluate(Split(c01, "|")(jj) & "!A1")) Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Split(c01, "|")(jj)
        End If
        With .Cells(1).CurrentRegion
            .AutoFilter 1, Split(c01, "|")(jj)
            .Copy Sheets(Split(c01, "|")(jj)).[A1]
            .AutoFilter
        End With
        
naam = ActiveSheet.Name
    Sheets(naam).Select
        Sheets(naam).Copy
    ActiveWorkbook.SaveAs Filename:= _
        "Q:\Batch\Lijst alle klanten\" & naam & ".xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        
        ActiveWorkbook.Close
        ThisWorkbook.Activate
        
    Next jj
End With

Nu wordt de klantnummer uit kolom 1 geplaats in het tablad en in het bestand van hoe hij wordt opgeslagen.
Ik zou nu ook kolom 2 er bij willen hebben dus dan wordt het bestand debnummer + naam

100693 klant1.xls
100946 klant2.xls
enz.

Ik zie dat het wordt weggeschreven met C01 maar ik snap nu niet wat ik moet aanpassen toevoegen om tot dit resultaat te komen

Is dat ook mogelijk!

HWV
 
Opgelost

Code: 
c00 = "Q:\Batch\Lijst alle klanten\"
Workbooks.Open (c00 & "lijst-artikelen-alle klanten.xls")
With Sheets("Data1")
    ar = Sheets("Data1").Cells(1).CurrentRegion
    Sheets("Data1").Range("A1:Z25000").Copy Workbooks("VS-Lijst alle klanten bewerken automatisch.xlsm").Sheets("Data1").Range("A1:Z25000")
    For j = 2 To UBound(ar)
        If InStr(1, c01, ar(j, 1)) = 0 Then c01 = c01 & "|" & ar(j, 1) [COLOR="#FF0000"]& " " & ar(j, 2)[/COLOR]
    Next j
    For jj = 1 To UBound(Split(c01, "|"))
        If IsError(Evaluate(Split(c01, "|")(jj) & "!A1")) Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Split(c01, "|")(jj)
        End If
        With .Cells(1).CurrentRegion
            .AutoFilter 1, Split(c01, "|")(jj)
            .Copy Sheets(Split(c01, "|")(jj)).[A1]
            .AutoFilter
        End With
        
naam = ActiveSheet.Name
    Sheets(naam).Select
        Sheets(naam).Copy
    ActiveWorkbook.SaveAs Filename:= _
        "Q:\Batch\Lijst alle klanten\" & naam & ".xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        
        ActiveWorkbook.Close
        ThisWorkbook.Activate
        
    Next jj
End With

Even goed nadenken en logisch nadenken en ben tot het juiste resultaat gekomen.

HWV
 
Nu helaas zonder artikelen gedraaid,

Beste VenA ,

Ik ben bezig met deze code te verwerken in mijn originele bestand.
Ik had het helemaal rond en vanmorgen de code laten draaien en werkte perfect..
Vanmiddag nogmaals, maar toen gaf hij alleen de kop hoofd te zien en niet de artikelen per klant.
Hij maak wel de tabbladen aan met nummer en naam en schrijf deze netjes weg op de gevraagde locatie.

Maar de bladen blijven leeg buiten de kophoofd.

Ik zie niet waar het fout gaat, kunt u mij hier ondersteunen!


Bekijk bijlage VS-Lijst alle klanten bewerken automatisch-1.xlsm
en
Bekijk bijlage lijst-artikelen-alle klanten.xls
 
Het blad wordt gefilterd op het debiteurennummer in kolom A.

Met wat jij ervan gemaakt hebt kan er nooit een waarde gevonden worden en krijg je alleen de kopregel. Voor het correct filteren moet je de klantnaam er dus weer uithalen.
Code: 
.AutoFilter 1, split(Split(c01, "|")(jj))(0)
 
Geweldig

VenA geweldig....

Ik zou hier nooit aan gedacht hebben om dit daar te zoeken.
Kan weer verder bouwen top, erg bedankt voor deze hulp! :thumb::thumb:

HWV
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan