Code export aanpassen

Status
Niet open voor verdere reacties.
T

tombeerke

Gebruiker
Lid geworden
8 jan 2017
Berichten
280
wie kan me helpen met het volgende:

bekijk de 2 ingevoegde bestanden, en wat ik wil bekomen is het volgende

In de werkmap "inkoopboek2017test" zijn verschillende tabbladen aanwezig, die ik nu 1 voor 1 kan exporteren naar de werkmap "stockbeheer2017test" tabblad "stockbeheer"
Nu zou ik graag onderstaande code aanpassen, dat dan het volgende gebeurt
Als ik de macro laat uitvoeren:
Stap 1: in de werkmap "stockbeheer2017test" alle cellen van "A12" tot "Z1000" te wissen (opgelet: in cellen "AA" tot "AI" staan formules dus deze moeten niet gewist worden
Stap 2: in de werkmap "inkoopboek2017test" als ik dan de macro uitvoer, dienen alle tabbladen met een tabbladnaam waarvan de lengte 9 karakters is bv"06022017A" de export doen naar werkmap "stockbeheer2017test" tabblad "stockbeheer"

de code die ik nu gebruik:
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 & "\StockBeheer2017test.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

Hier de voorbeeldbestandjes

Bekijk bijlage InkoopBoek2017Test.xlsm Bekijk bijlage StockBeheer2017Test.xlsm

Tom
 
Code: 
With .Sheets("stockbeheer")
[COLOR=#0000ff]  .range("A14:Z1000").clear[/COLOR]
Set rng = .Cells(Application.Max(14, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 2)
 
werkt prima ! het deleten
Alleen moet er nu nog de aanpassing gebeuren, dat niet enkel het actief tabblad wordt geexporteerd, maar alle tabbladen met lengte 9 bv "19042017a" uit de werkmap inkoopboek2017test
 
Code: 
Sub TestExportStockbeheer2017()
Dim Sh As Worksheet, c As Range, rng As Range, cl As Range
Application.ScreenUpdating = False
With GetObject(ThisWorkbook.Path & "\StockBeheer2017test.xlsb")
.Windows(1).Activate
  With .Sheets("stockbeheer")
  .Range("A14:Z1000").Clear
[COLOR=#0000ff]  for each sh in thisworkbook.sheets[/COLOR]
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
[COLOR=#0000ff]     next sh[/COLOR]
     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
 
zit een klein foutje in de code

de code exporteert ook de factuurdatum mee naar kolom W in stockbeheer2017test, de code doet het prima, enkel bij de laatste rij van bv tabblad 06022017A plaats hij de factuurdatum van 19022017A

hieronder afbeelding: (geel gearceerd factuurdatum moet 6/02/2017 zijn ipv 19/02/2017
Code: 
[ATTACH]298297.vB[/ATTACH]
 

Bijlagen

  • fout factuurdatum.JPG
    fout factuurdatum.JPG
    100,3 KB · Weergaven: 81
Harry,

heb de code naar mijn definitieve sheets geplaatst en daar werk alles wel prima, dus vraag hierboven is opgelost :thumb::thumb:
 
Harry,

de code aanpassen voor stockbeheer werkt prima, heb deze geplaatst in Private Sub Workbook_BeforeClose(Cancel As Boolean) en alles klopt :thumb::thumb:

Ik wil dit nu ook doen voor mijn werkmap "importlabels"

Ik heb de code aangepast maar mijn export verloopt VERKEERD !

de code kopieert veel te veel (wel 50000 rijen ?) en vele rijen geven de tekst #waarde weer (begrijp niet vanwaar deze komen)

ik had ook graag gehad dat de rijen uit werkmap "inkoopboek" waar de kolom (H) stock = 0 niet mee worden gekopieerd (op deze wijze heb ik steeds de laatste versie voor het printen van mijn labels, en wordt de lijst niet onoverzichtelijk door alle aanwezige artikelen die toch al uitverkocht zijn !)

Ook wilde ik de msgbox wegdoen (omdat de data steeds eerst gedelete wordt, en dan terug geplaatst) maar kreeg dan ook een foutmelding (ik denk omdat mijn "next sh" verkeerd staat)



Code: 
Sub ExportLabels2017()
Dim Sh As Worksheet, c As Range, rng As Range, sn, st, j As Long, c00 As String
Application.ScreenUpdating = False
Set Sh = ActiveSheet
With GetObject(ThisWorkbook.Path & "\ImportLabels.xls")
.Windows(1).Activate
  With .Sheets("2017Labels")
 [COLOR="#0000CD"] .Range("A2:A2500").Clear
  .Range("F2:F2500").Clear
  .Range("G2:G2500").Clear
  .Range("H2:H2500").Clear
  For Each Sh In ThisWorkbook.Sheets[/COLOR]
   Set c = .Columns(7).Find(Sh.Name)
    If c Is Nothing Then
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 = 1 To UBound(sn)
        c00 = c00 & Replace(String(sn(j, 7), " "), " ", " " & 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)
 .Cells(Application.Max(2, .Cells(Rows.Count, 7).End(xlUp).Offset(1).Row), 7).Resize(UBound(st)) = Sh.Name
    End If
   
  Else
   MsgBox "Data al aanwezig!"
  End If
  [COLOR="#0000CD"] Next Sh[/COLOR]
    
 End With
  
End With

End Sub

Als je graag hebt dat ik het resultaat bestand importlabels upload, laat maar weten

Tom
 
Deze had ik er niet in staan.
Code: 
Set Sh = ActiveSheet
 
Ik heb de 2 bestanden ingevoegd

Als je kijkt in inkoopboek2017test bij macro "importlabels2017", daar heb ik de code aangepast zoals hierboven aangegeven.
Als ik deze macro nu uitvoer, en we bekijken "importlabels2017" tabblad labels2017, loopt er iets verkeerd met de code en geeft hij opeens in 3 cellen #waarde aan

Ook als bij kolom H "stock" 0 is, moet de rij niet gekopieerd worden (dit is de reden van de aanpassing, omdat nu de lijst importlijst veel te lang wordt en veel artikelen die uitverkocht zijn blijven staan in de lijst)

Tom

Bekijk bijlage InkoopBoek2017Test.xlsm
Bekijk bijlage ImportLabels.xls
 
c00 wel leeg maken bij de for next.
Code: 
Sub ExportLabels2017()
Dim Sh As Worksheet, c As Range, rng As Range, sn, st, j As Long, c00 As String
Application.ScreenUpdating = False


With GetObject(ThisWorkbook.Path & "\ImportLabels.xls")
.Windows(1).Activate
  With .Sheets("2017Labels")
  .Range("A2:A2500").Clear
  .Range("F2:F2500").Clear
  .Range("G2:G2500").Clear
  .Range("H2:H2500").Clear
  For Each Sh In ThisWorkbook.Sheets
  
   Set c = .Columns(7).Find(Sh.Name)
    If c Is Nothing Then
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 = 1 To UBound(sn)
        c00 = c00 & Replace(String(sn(j, 7), " "), " ", " " & 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)
 .Cells(Application.Max(2, .Cells(Rows.Count, 7).End(xlUp).Offset(1).Row), 7).Resize(UBound(st)) = Sh.Name
    End If
'  Else
'   MsgBox "Data al aanwezig!"
  End If
[COLOR=#0000ff]  c00 = ""[/COLOR]
  Next Sh
  
 End With
End With
End Sub
 
Werkt PRIMA :thumb::thumb::thumb:

ik wil nu een extra kolom meenemen, namelijk kolom U van rij 236 tot 337 (U236:U337) en deze plaatsen in werkmap "importlabels" op kolom H (ik kan dit niet doen met verticaal zoeken omdat de soldenprijs niet mee geexporteerd wordt naar stockbeheer2017)

ik weet alleen niet hoe ik in de code deze extra cel moet bijvoegen

Code: 
 sn = Sh.Range("B22:H" & Application.Max(22, Sh.Cells(123, 2).End(xlUp).Row))

of ben ik fout aan zoeken ?
 
Zeer waarschijnlijk, maar geen garantie.
Code: 
 sn = Sh.Range("U236:U" & Application.Max(236, Sh.Cells(337, 21).End(xlUp).Row))
 
Ik heb vandaag alles van de "testomgeving" geplaatst naar de definitieve werkmappen, en tot zover werkt alles PRIMA !

Dataexport naar stockbeheer2017 is volledig KLAAR !

wat de labels betreft wilde ik dus die extra kolom mee exporteren

Code: 
sn = Sh.Range("U236:U" & Application.Max(236, Sh.Cells(337, 21).End(xlUp).Row))

je geeft die code, maar de huidige code moet ook blijven exporteren

Code: 
sn = Sh.Range("B22:H" & Application.Max(22, Sh.Cells(123, 2).End(xlUp).Row))

Als ik je code erbij plak krijg ik een foutmelding

ik vermoed omdat er nu 2 "sn" zijn (en in de nieuwe code zie ik wel welke range er moet gekopieerd worden, en die klopt volgens mij, maar zie nergens staan waar de code de nieuwe plaatst van export aangeeft, moet komen in werkmap Importlabels, sheet 2017Labels

Daar komt dan mijn volgende vraag direct achter:

Ik wil in de werkmap ImportLabels, 2 tabbladen aanmaken, 2016Labels, 2017labels (dus ga werken met 2 knoppen, eentje voor 2016 & 2017), nu gebruiken we in de code For Each Sh in thisWorkbook.sheets .... kunnen we ergens een verwijzing of aanpassing voorzien waar gekeken wordt naar 2016 of 2017 in de tabbladnaam ?

Of is het handiger na de export, dat in de werkmap importlabels een macro wordt uitgevoerd, die dan de labels van 2017 op een ander tabblad plaatst automatisch (probeer maar mee te denken he :) )

tom

Update:
Voor het exporteren voor de labels loopt er ook foutmelding als volgende gebeurtenis optreedt
Als een tabblad bv: 25052016 alle artikelen zijn uitverkocht (dus alle stock staat op 0) loopt de code vast hierop
Code: 
st = Application.Transpose(Split(Trim(c00)))
Ook als ik het tabblad verberg, blijft de foutmelding actief

Het rare is dat bij de andere code voor het exporteren van de data naar stockbeheer, er dan weer geen foutmelding optreed en de code wel werkt (tabblad zichbaar of verborgen heeft ook geen invloed)
Ik heb de data nodig, ook al zijn alle artikelen uitverkocht = stock overal 0, omdat ik de aantallen nodig heb van aankoop !
 
Laatst bewerkt:
Waar kan de factuur naartoe.

Code: 
[COLOR=#0000ff]if c00 <>"" then[/COLOR]
   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)
   .Cells(Application.Max(2, .Cells(Rows.Count, 7).End(xlUp).Offset(1).Row), 7).Resize(UBound(st)) = Sh.Name
[COLOR=#0000ff]end if[/COLOR]
 
Aanpassing werk weer PRIMA :thumb::thumb::thumb:
De factuur, ik begrijp dat je veel werk steek in al mijn vragen hoor, en ben je daar dankbaar voor !

kan je wel een kledingstuk aanbieden, alleen hebben we alleen dames artikelen :)
 
Geen probleem, ik heb drie dames.
De maten geef ik je nog door.
 
Durf nu niks meer vragen he :eek::eek::eek:
maar zit nog vast met die extra kolom om mee te exporteren
 
De range die je aangeeft U236:U337 is een geheel andere range dan B22:B123.
Die gegevens horen toch niet naast elkaar?
 
Ik begrijp dat je niet direct een verband ziet !
Ik probeer het uit te leggen, zodoende je een beeld krijgt van mijn probleem.

Fase 1:
we exporteren heel wat data naar stockbeheer, in feite bijna alles van range B22:U123 (dat werkt allemaal perfect)
In feite is deze Range, het inkooporder, dus tot en met Rij 123 zijn gegevens van de aankoop

Fase 2:
Hier exporteren we de gegevens naar importlabels, maar enkel de artikelnummer en de stock, alle andere data ga ik ophalen via verticaal zoeken in stockbeheer

In mijn tabblad heb ik in feite 4 verkoopsdocumenten ingebouwd, ik leg uit
Van Range B129:M230 is verkoopsdocument 1 (hier worden de Verkoopprijzen van rangeU22-U123) automatisch ingevuld
Van Range O129:U230 is verkoopsdocument 2 (hier kunnen we de verkoopsprijzen handmatig invullen)
Van Range B236:M337 is verkoopsdocument 3 (is handmatig in te vullen, is voor onze consulentes en gastvrouwen)
Van Range 0236:u337 is verkoopsdocument 4 (en nu komen we er, U236:U337 wordt de SOLDENPRIJS ingevuld door ons, en zou deze gegevens moeten worden geexporteerd naar Importlabels Kolom H

Rij U236 is van artikelnaam, nummer enz = Rij B22
Rij U237 is van artikelnaam, nummer enz = Rij B23

Waarom hebben we dat nu nodig, op de etiket labels voor SOLDEN worden de 2 prijzen afgedrukt, de VERKOOPPRIJS en de SOLDENPRIJS

begrijp je dit allemaal ??? Voor mij is het "zichtbaar" omdat ik zelf het tabblad heb ontwikkeld, en werkt prima voor ons :eek:
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan